Помните, что когда вы пишете:
MyArray = Range("A1:A5000")
вы действительно пишете
MyArray = Range("A1:A5000").Value
Вы также можете использовать имена:
MyArray = Names("MyWSTable").RefersToRange.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 должен иметь значениеТиповой вариант.Я попробовал оба варианта и long для ColourArray без успеха.
Я заполнил ColourArray значениями и попробовал следующее утверждение:
.Range("A1:T5000").Font.Color = ColourArray
Весь диапазон будет окрашен в соответствии с первым элементом ColourArrayа затем Excel зациклился, занимая около 45% процессорного времени, пока я не завершил его с помощью диспетчера задач.
Существует временное ограничение, связанное с переключением между листами, но недавние вопросы о продолжительности макроса заставили всех пересмотреть наше мнениечто работа с массивами была значительно быстрее.
Я построил эксперимент, который широко отражает ваши требования.Я заполнил рабочий лист Time1 5000 строками по 20 ячеек, которые были выборочно отформатированы следующим образом: жирный, курсив, подчеркивание, нижний индекс, границы, красный, зеленый, синий, коричневый, желтый и серый - 80%.
В версии 1Я скопировал каждую седьмую ячейку из рабочей таблицы «Time1» в рабочую таблицу «Time2», используя копию.
В версии 2 я скопировал каждую седьмую ячейку из рабочей таблицы «Time1» в рабочую таблицу «Time2», скопировав значение ицвет через массив.
В версии 3 я копировал каждую седьмую ячейку с рабочего листа «Time1» на рабочий лист «Time2», копируя формулу и цвет через массив.
Версия 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 **
Определение типа пользователя должно быть помещено перед любой подпрограммой вмодуль.Код работает через исходную рабочую таблицу, копируя значения или формулы и цвета в следующий элемент массива.После того, как выбор был завершен, он копирует собранную информацию на лист назначения.Это позволяет избежать переключения между листами больше, чем это необходимо.
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