如何合并excel中的两个单元格(包含内容)使用VBA保持格式不变?

我有两个单元格A1和A2。 我想合并它们并保存在A3中保持格式不变。 我能够使用下面的代码来做到这一点。 但是有一个巨大的性能问题。 任何人可以提出更好的解决scheme? 有一个更简单的方法来做到这一点?

Sub Merge_Cells(rngFrom1 As Range, rngFrom2 As Range, rngTo As Range) Dim iOS As Integer Dim lenFrom1 As Integer Dim lenFrom2 As Integer Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlManual lenFrom1 = rngFrom1.Characters.Count lenFrom2 = rngFrom2.Characters.Count rngTo.Value = rngFrom1.Text & rngFrom2.Text For iOS = 1 To lenFrom1 With rngTo.Characters(iOS, 1).Font .Bold = rngFrom1.Characters(iOS, 1).Font.Bold .Size = 9 'rngFrom1.Characters(iOS, 1).Font.Size .Color = rngFrom1.Characters(iOS, 1).Font.Color .Italic = rngFrom1.Characters(iOS, 1).Font.Italic .Strikethrough = rngFrom1.Characters(iOS, 1).Font.Strikethrough .Underline = rngFrom1.Characters(iOS, 1).Font.Underline End With Next iOS For iOS = 1 To lenFrom2 With rngTo.Characters(lenFrom1 + iOS, 1).Font .Name = rngFrom2.Characters(iOS, 1).Font.Name .Bold = rngFrom2.Characters(iOS, 1).Font.Bold .Size = 9 'rngFrom2.Characters(iOS, 1).Font.Size .Color = rngFrom2.Characters(iOS, 1).Font.Color .Italic = rngFrom2.Characters(iOS, 1).Font.Italic .Strikethrough = rngFrom2.Characters(iOS, 1).Font.Strikethrough .Underline = rngFrom2.Characters(iOS, 1).Font.Underline End With Next iOS Application.Calculation = xlAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub 

三点build议:

1.只有在需要时才设置angular色的属性

这是可能的(我不知道肯定)设置一个angular色的属性比获得一个angular色的属性更昂贵。 如果成本差异足够大,那么在实际设置之前检查属性是否需要设置是有意义的。

所以,例如,你的代码将变成:

 Sub Merge_Cells2(rngFrom1 As Range, rngFrom2 As Range, rngTo As Range) Dim iOS As Integer Dim lenFrom1 As Integer Dim lenFrom2 As Integer Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlManual lenFrom1 = rngFrom1.Characters.Count lenFrom2 = rngFrom2.Characters.Count rngTo.Value = rngFrom1.Text & rngFrom2.Text For iOS = 1 To lenFrom1 With rngTo.Characters(iOS, 1).Font If .Bold <> rngFrom1.Characters(iOS, 1).Font.Bold Then .Bold = rngFrom1.Characters(iOS, 1).Font.Bold If .Size <> 9 Then .Size = 9 If .Color <> rngFrom1.Characters(iOS, 1).Font.Color Then .Color = rngFrom1.Characters(iOS, 1).Font.Color If .Italic <> rngFrom1.Characters(iOS, 1).Font.Italic Then .Italic = rngFrom1.Characters(iOS, 1).Font.Italic If .StrikeThrough <> rngFrom1.Characters(iOS, 1).Font.StrikeThrough Then .StrikeThrough = rngFrom1.Characters(iOS, 1).Font.StrikeThrough If .Underline <> rngFrom1.Characters(iOS, 1).Font.Underline Then .Underline = rngFrom1.Characters(iOS, 1).Font.Underline End With Next iOS For iOS = 1 To lenFrom2 With rngTo.Characters(lenFrom1 + iOS, 1).Font If .Bold <> rngFrom2.Characters(iOS, 1).Font.Bold Then .Bold = rngFrom2.Characters(iOS, 1).Font.Bold If .Size <> 9 Then .Size = 9 If .Color <> rngFrom2.Characters(iOS, 1).Font.Color Then .Color = rngFrom2.Characters(iOS, 1).Font.Color If .Italic <> rngFrom2.Characters(iOS, 1).Font.Italic Then .Italic = rngFrom2.Characters(iOS, 1).Font.Italic If .StrikeThrough <> rngFrom2.Characters(iOS, 1).Font.StrikeThrough Then .StrikeThrough = rngFrom2.Characters(iOS, 1).Font.StrikeThrough If .Underline <> rngFrom2.Characters(iOS, 1).Font.Underline Then .Underline = rngFrom2.Characters(iOS, 1).Font.Underline End With Next iOS Application.Calculation = xlAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub 

正如我所说,我不知道这是否是一场胜利,而且每个财产的优势程度也可能不一样。 也许有人比我更懂得评论。 或者你可以试试看看是否有帮助。

2.一次设置大小

由于您似乎一直将尺寸设置为9,所以我build议将整个单元的大小设置为9,而不是一个字符。 然后再次,也许你评论它,因为你打算恢复大小复制,如果是这样,这个build议将无法正常工作。

3.利用稀疏

如果格式是稀疏的,那么你可以在你做任何事情之前检查特定属性的长字符(或整个单元格)。 例如,如果许多单元格没有粗体,请在执行其他任何操作之前检查每个单元格。 你可能不需要做任何关于粗体的事情。 当一个属性在字符运行中不统一时,我的Excel将返回Null。 (ymmv)如果你得到一个空值,那么你就知道你必须把这个angular色分割得更细。

4.附录

@DavidZemens关于字体大小的build议让我想到了这个想法,只有在设置比获取字符属性更昂贵的情况下才能获得回报。 人们可以通过检查制定一个最常见的字体风格(字体,大小,颜色,粗体等)的猜测,将其定义为单元格样式并手动将其应用于目标范围。 这将最小化触发属性设置的If的数量。

-hth