Remember that when you write:
MyArray = Range("A1:A5000")
you really write
MyArray = Range("A1:A5000").Value
You can also use the names:
MyArray = Names("MyWSTable").RefersToRange.Value
But Value is not the only property of Range. I used:
MyArray = Range("A1:A5000").NumberFormat
I doubt that
MyArray = Range("A1:A5000").Font
but i would expect
MyArray = Range("A1:A5000").Font.Bold
for work.
I do not know which formats you want to copy, so you have to try.
However, I must add that when you copy and paste a large range, it is not much slower than doing it through an array, as we all thought.
Publish Editing Information
Having laid out the above, I tried my own advice. My experiments with copying Font.Color and Font.Bold to an array failed.
Of the following statements, the second will fail with a type mismatch:
ValueArray = .Range("A1:T5000").Value ColourArray = .Range("A1:T5000").Font.Color
ValueArray must be of type variant. I tried both options and for a long time for ColourArray without success.
I populated a ColourArray with values and tried the following statement:
.Range("A1:T5000").Font.Color = ColourArray
The entire range will be colored according to the first ColourArray element, and then Excel will loop, consuming about 45% of the CPU time, until I have completed it using the task manager.
There is a time limit associated with switching between sheets, but recent questions about the duration of the macro have forced everyone to reconsider our belief that working with arrays is much faster.
I built an experiment that generally reflects your requirement. I filled out a Time1 worksheet with 5,000 rows of 20 cells that were selectively formatted as: bold, italics, underline, bottom, border, red, green, blue, brown, yellow, and gray - 80%.
With version 1, I copied every 7th cell from the "Time1" sheet to the "Time2" worksheet using a copy.
With version 2, I copied every 7 cells from the "Time1" worksheet to the "Time2" worksheet, copying the value and color through the array.
With version 3, I copied every 7th cell from the "Time1" sheet to the "Time2" worksheet, copying the formula and color through the array.
Version 1 took an average of 12.43 seconds, and the second version took an average of 1.47 seconds, while version 3 took an average of 1.83 seconds. Version 1 copied the formulas and all the formatting, copied the values and color of version 2, and version 3 copied the formulas and color. With versions 1 and 2, you can add bold and italics, say, and still have some time in your hand. However, I'm not sure what to worry about, given that copying 21,300 values takes only 12 seconds.
** Code for version 1 **
I do not think this code contains anything that needs explanation. Reply with a comment if I am wrong and I will correct it.
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
** Code for versions 2 and 3 **
A user type definition must be placed before any subroutine in the module. The code works through the source sheet, copying the values or formulas and colors into the next element of the array. After the selection is completed, it copies the collected information to the destination sheet. This avoids switching between sheets more than necessary.
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