У меня есть два фрагмента кода. Сначала стандартная копия-вставка из ячейки 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
Для меня это невозможно. Но если это соответствует вашим потребностям, вы можете получить скорость и форматирование, копируя весь диапазон сразу, вместо циклического копирования:
range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)
И, кстати, вы можете построить пользовательскую строку диапазона, например Range("B2:B4, B6, B11:B18")
.
редактирование: если ваш источник "разреженный", не можете ли вы просто отформатировать место назначения сразу после завершения копирования?
Помните об этом, когда пишете:
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
Делает:
Set Sheets("Output").Range("$A$1:$A$500") = Sheets(sheet_).Range("$A$1:$A$500")
... работает? (У меня нет Excel перед глазами, поэтому я не могу проверить).