быстрый способ копирования форматирования в excel

У меня есть два фрагмента кода. Сначала стандартная копия-вставка из ячейки A в ячейку B

Sheets(sheet_).Cells(x, 1).Copy Destination:=Sheets("Output").Cells(startrow, 2)

Я могу сделать почти то же самое, используя

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)

Теперь этот второй метод намного быстрее, он позволяет избежать копирования в буфер обмена и повторной вставки. Однако он не копирует форматирование, как это делает первый метод. Вторая версия практически мгновенно копирует 500 строк, в то время как первый метод добавляет около 5 секунд к этому времени. А в окончательном варианте может быть до 5000 ячеек.

Поэтому мой вопрос: можно ли изменить вторую строку, чтобы включить форматирование ячеек (в основном цвет шрифта) и при этом сохранить скорость.

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

Поэтому моим идеальным решением было бы что-то вроде

for x = 0 to 5000
array(x) = Sheets(sheet_).Cells(x, 1) 'including formatting
next

for x = 0 to 5000
Sheets("Output").Cells(x, 1)
next

можно ли использовать строки RTF в VBA или это возможно только в vb.net и т.д.

*Ответ**

Чтобы посмотреть, как сравниваются мой оригинальный метод и новый метод, вот результаты до и после

Новый код = 65 мсек

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Sheets("Output").Range("B" & startrow).Font.ColorIndex = Sheets(sheet_).Range("A" & x).Font.ColorIndex 'copy font colour as well

Старый код = 1296 мсек

'Sheets("Output").Cells(startrow, 2).Value = Sheets(sheet_).Cells(x, 1)
'Sheets(sheet_).Cells(x, 1).Copy
'Sheets("Output").Cells(startrow, 2).PasteSpecial (xlPasteFormats)
'Application.CutCopyMode = False
DevilWAH
Редактировал вопрос 23-го декабря 2011 в 9:12
Программирование
vba copy format rtf
23-го декабря 2011 в 2:27
20 просмотров
Решение

Для меня это невозможно. Но если это соответствует вашим потребностям, вы можете получить скорость и форматирование, копируя весь диапазон сразу, вместо циклического копирования:

range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)

И, кстати, вы можете построить пользовательскую строку диапазона, например Range("B2:B4, B6, B11:B18").

редактирование: если ваш источник "разреженный", не можете ли вы просто отформатировать место назначения сразу после завершения копирования?

Patrick Honorez
Редактировал ответ 23-го декабря 2011 в 3:08
Комментарии (8)

Помните об этом, когда пишете:

MyArray = Range("A1:A5000")

вы действительно пишете

MyArray = Range("A1:A5000").Value

Вы также можете использовать имена:

MyArray = Names("MyWSTable").RefersToRange.Value

Но Value - не единственное свойство Range. Я использовал:

MyArray = Range("A1:A5000").NumberFormat

Я сомневаюсь

MyArray = Range("A1:A5000").Font

будет работать, но я бы ожидал

MyArray = Range("A1:A5000").Font.Bold

будет работать.

Я не знаю, какие форматы вы хотите скопировать, поэтому вам придется попробовать.

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

После редактирования информации

Написав вышеизложенное, я попробовал по собственному совету. Мои эксперименты с копированием Font.Color и Font.Bold в массив не увенчались успехом.

Из следующих утверждений второе завершилось бы неудачей из-за несоответствия типов:

  ValueArray = .Range("A1:T5000").Value
  ColourArray = .Range("A1:T5000").Font.Color

ValueArray должен иметь тип variant. Я безуспешно пробовал и variant, и long для ColourArray.

Я заполнил ColourArray значениями и попробовал следующий оператор:

  .Range("A1:T5000").Font.Color = ColourArray

Весь диапазон окрашивался в соответствии с первым элементом ColourArray, после чего Excel зацикливался, потребляя около 45% процессорного времени, пока я не завершил его с помощью диспетчера задач.

Переключение между рабочими листами требует определенного времени, но недавние вопросы о длительности макросов заставили всех пересмотреть наше мнение о том, что работа с массивами значительно быстрее.

Я провел эксперимент, который в общих чертах отражает ваше требование. Я заполнил рабочий лист Time1 5000 рядами по 20 ячеек, которые были выборочно отформатированы следующим образом: полужирный, курсив, подчеркивание, подстрочный индекс, рамка, красный, зеленый, синий, коричневый, желтый и серый-80%.

В версии 1 я скопировал все 7 ячеек с рабочего листа "Время1" на рабочий лист "Время2" с помощью команды copy.

В версии 2 я копировал каждую 7-ю ячейку из рабочего листа "Время1" в рабочий лист "Время2", копируя значение и цвет через массив.

В версии 3 я копировал каждую 7-ю ячейку из рабочего листа "Время1" в рабочий лист "Время2", копируя формулу и цвет через массив.

Версия 1 заняла в среднем 12,43 секунды, версия 2 заняла в среднем 1,47 секунды, а версия 3 заняла в среднем 1,83 секунды. Версия 1 копировала формулы и все форматирование, версия 2 копировала значения и цвет, а версия 3 копировала формулы и цвет. В версиях 1 и 2 можно добавить, скажем, полужирный шрифт и курсив, и все еще иметь некоторое время в запасе. Однако я не уверен, что это стоит того, учитывая, что копирование 21 300 значений занимает всего 12 секунд.

Код для версии 1

Я не думаю, что в этом коде есть что-то, что нуждается в объяснении. Если я ошибаюсь, напишите комментарий, и я исправлю.

Sub SelectionCopyAndPaste()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  Do While True
    ColSrcCrnt = (NumSelect Mod 20) + 1
    RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
    If RowSrcCrnt > 5000 Then
      Exit Do
    End If
    Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
                 Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
    If ColDestCrnt = 20 Then
      ColDestCrnt = 1
      RowDestCrnt = RowDestCrnt + 1
    Else
     ColDestCrnt = ColDestCrnt + 1
    End If
    NumSelect = NumSelect + 7
  Loop
  Debug.Print Timer - StartTime
  ' Average 12.43 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

Код для версий 2 и 3

Определение типа User должно быть размещено перед любой подпрограммой в модуле. Код работает через исходный рабочий лист, копируя значения или формулы и цвета к следующему элементу массива. После завершения выбора он копирует собранную информацию на рабочий лист назначения. Это позволяет избежать переключения между рабочими листами чаще, чем это необходимо.

Type ValueDtl
  Value As String
  Colour As Long
End Type

Sub SelectionViaArray()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim InxVLCrnt As Integer
  Dim InxVLCrntMax As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single
  Dim ValueList() As ValueDtl

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  ' I have sized the array to more than I expect to require because ReDim
  ' Preserve is expensive.  However, I will resize if I fill the array.
  ' For my experiment I know exactly how many elements I need but that
  ' might not be true for you.
  ReDim ValueList(1 To 25000)

  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  InxVLCrntMax = 0      ' Last used element in ValueList.
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  With Sheets("Time1")
    Do While True
      ColSrcCrnt = (NumSelect Mod 20) + 1
      RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
      If RowSrcCrnt > 5000 Then
        Exit Do
      End If
      InxVLCrntMax = InxVLCrntMax + 1
      If InxVLCrntMax > UBound(ValueList) Then
        ' Resize array if it has been filled 
        ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
      End If
      With .Cells(RowSrcCrnt, ColSrcCrnt)
        ValueList(InxVLCrntMax).Value = .Value              ' Version 2
        ValueList(InxVLCrntMax).Value = .Formula            ' Version 3
        ValueList(InxVLCrntMax).Colour = .Font.Color
      End With
      NumSelect = NumSelect + 7
    Loop
  End With
  With Sheets("Time2")
    For InxVLCrnt = 1 To InxVLCrntMax
      With .Cells(RowDestCrnt, ColDestCrnt)
        .Value = ValueList(InxVLCrnt).Value                 ' Version 2
        .Formula = ValueList(InxVLCrnt).Value               ' Version 3
        .Font.Color = ValueList(InxVLCrnt).Colour
      End With
      If ColDestCrnt = 20 Then
        ColDestCrnt = 1
        RowDestCrnt = RowDestCrnt + 1
      Else
       ColDestCrnt = ColDestCrnt + 1
      End If
    Next
  End With
  Debug.Print Timer - StartTime
  ' Version 2 average 1.47 secs
  ' Version 3 average 1.83 secs
  Application.Calculation = xlCalculationAutomatic

End Sub
Tony Dallimore
Редактировал ответ 26-го декабря 2011 в 10:19
Комментарии (0)

Делает:

Set Sheets("Output").Range("$A$1:$A$500") =  Sheets(sheet_).Range("$A$1:$A$500")

... работает? (У меня нет Excel перед глазами, поэтому я не могу проверить).

Комментарии (3)