Блог

У меня есть две ячейки A1 и A2. Я хочу объединить их и сохранить в формате A3, сохранив форматирование без изменений. Для этого я смог использовать приведенный ниже код. Но существует огромная проблема с производительностью. Может ли кто-нибудь предложить лучшее решение? Есть ли более простой способ сделать это?

     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 amp; 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
 

Три предложения:

1. Устанавливайте свойства персонажа только в том случае, если вам необходимо

Возможно (я не знаю наверняка), что установка свойств персонажа обходится дороже, чем получение свойств персонажа. Если разница в затратах достаточно высока, имеет смысл проверить свойство, чтобы узнать, нужно ли его устанавливать, прежде чем вы его установите.

Так, например, ваш код станет:

 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 amp; 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. Установите размер сразу

Поскольку вы, похоже, все время устанавливаете size равным 9, я бы предложил установить size равным 9 для всей ячейки сразу, а не посимвольно. Опять же, возможно, вы прокомментировали это, потому что собираетесь восстановить копирование размера, и если это так, это предложение не сработает.

3. Используйте разреженность

Если форматирование разреженное, вы можете проверить длинные строки символов (или целые ячейки) для определенного свойства, прежде чем что-либо делать. Например, если многие ячейки не выделены жирным шрифтом, проверьте каждую ячейку, прежде чем делать что-либо еще. Возможно, вам вообще не придется ничего делать с выделением жирным шрифтом. Мой Excel возвращает Null, когда свойство не является одинаковым для набора символов. (ymmv) Если вы получите значение Null, то вы знаете, что вам придется нарезать этот символ более мелко.

4. Дополнение

предложение @DavidZemens о размере шрифта привело меня к этой идее, которая окупается, только если Set дороже, чем Get для свойств символов. Можно путем проверки сформулировать предположение о наиболее распространенном стиле символов (шрифт, размер, цвет, жирный шрифт и т.д.), Определить это вручную как стиль ячейки и применить его к целевому диапазону вручную. Это минимизировало бы количество If, которые запускают наборы свойств.

-hth