fast way to copy formatting in excel

You could have simply used Range("x1").value(11) something like below:

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

range has default property "Value" plus value can have 3 optional orguments 10,11,12.11 is what you need to tansfer both value and formats. It doesn't use clipboard so it is faster.- Durgesh

For me, you can't. But if that suits your needs, you could have speed and formatting by copying the whole range at once, instead of looping:

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

And, by the way, you can build a custom range string, like Range("B2:B4, B6, B11:B18")

edit: if your source is "sparse", can't you just format the destination at once when the copy is finished ?

Remember that when you write:

MyArray = Range("A1:A5000")

you are really writing

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

You can also use names:

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

But Value is not the only property of Range. I have used:

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

I doubt

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

would work but I would expect

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

to work.

I do not know what formats you want to copy so you will have to try.

However, I must add that when you copy and paste a large range, it is not as much slower than doing it via an array as we all thought.

Post Edit information

Having posted the above I tried by own advice. My experiments with copying Font.Color and Font.Bold to an array have failed.

Of the following statements, the second would 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 variant and long for ColourArray without success.

I filled ColourArray with values and tried the following statement:

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

The entire range would be coloured according to the first element of ColourArray and then Excel looped consuming about 45% of the processor time until I terminated it with the Task Manager.

There is a time penalty associated with switching between worksheets but recent questions about macro duration have caused everyone to review our belief that working via arrays was substantially quicker.

I constructed an experiment that broadly reflects your requirement. I filled worksheet Time1 with 5000 rows of 20 cells which were selectively formatted as: bold, italic, underline, subscript, bordered, red, green, blue, brown, yellow and gray-80%.

With version 1, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" using copy.

With version 2, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the value and the colour via an array.

With version 3, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the formula and the colour via an array.

Version 1 took an average of 12.43 seconds, version 2 took an average of 1.47 seconds while version 3 took an average of 1.83 seconds. Version 1 copied formulae and all formatting, version 2 copied values and colour while version 3 copied formulae and colour. With versions 1 and 2 you could add bold and italic, say, and still have some time in hand. However, I am not sure it would be worth the bother given that copying 21,300 values only takes 12 seconds.

** Code for Version 1**

I do not think this code includes anything that needs an explanation. Respond with a comment if I am wrong and I will fix.

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 = xlCalculationAutomaticEnd Sub

** Code for Versions 2 and 3**

The User type definition must be placed before any subroutine in the module. The code works through the source worksheet copying values or formulae and colours to the next element of the array. Once selection has been completed, it copies the collected information to the destination worksheet. This avoids switching between worksheets more than is essential.

Type ValueDtl  Value As String  Colour As LongEnd TypeSub 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 = xlCalculationAutomaticEnd Sub