patternMinor
Copy and paste formatting is slow using VBA
Viewed 0 times
formattingslowpasteusingvbaandcopy
Problem
The following code is a function that works. It's just slow and I don't know how to speed it up. It takes an Excel row number and the value of its headerval (string) and finds the same headerval on a different sheet then copies the formatting and applies it to our new sheet. The true false is because the source sheet has 2 different formatting options. It passes in the row to use either 23 or 24. ZROW is a public variable which is set with the ROW to start looking. srccolbyname function gets a col number from the source sheet which has the same headerval.
As requested here is the support function referenced above.
Function formatrow(roww As Long, header As Boolean)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim headerval As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("DEALSHEET")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Sheets("Sheet1")
If header = True Then: srcrow = 23: Else: srcrow = 24
LastColumn = sht.Cells(ZROW + 1, sht.Columns.Count).End(xlToLeft).Column
For x = 2 To LastColumn
headerval = sht.Cells(ZROW + 1, x).Value
srccol = srccolbyname(headerval)
sht2.Cells(srcrow, srccol).Copy 'THIS IS SLOW
sht.Cells(roww, x).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next x
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End FunctionAs requested here is the support function referenced above.
Public Function srccolbyname(strng_name As String) As Integer
Call findcol 'find ZROW
Dim x As Integer
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Sheet1")
LastColumn = sht.Cells(22, sht.Columns.Count).End(xlToLeft).Column
For x = 2 To LastColumn
chkval = sht.Cells(22, x).Value
If Trim(UCase(chkval)) = Trim(UCase(strng_name)) Then
srccolbyname = x
Exit For
Else
srccolbyname = 2
End If
Next x
End FunctionSolution
This:
Would be much better off as an
Also note, this:
..is always redundant and can be written as:
With
One of the most important things to do when you have blocks in your code (
Here's your function, properly indented:
Notice how much easier it is to see where the loop starts, where it ends, and what's in its body.
Now sure what
You declared
But then, if these sheets aren't dynamically generated, you shouldn't need to query any worksheet collection and get the objects by their "sheet name" (which the users can change at any time!) - instead, use their "code name": VBA defines a global-scope object for every Excel object (including
And then do this (assuming the sheet labelled "DEALSHEET" is named
And this:
And that:
And so on.
Now, about performance. You need a radically different approach. How would you do it if you were going to do it manually? Would you Copy+Paste one cell at a time, or Copy+Paste the whole row at once?
You want to copy/paste the formats on
No need to loop, no need to lookup column numbers. Unless I missed something. Should be much faster!
I also ran Rubberduck inspections (build 2.0.10, not released yet). A few things to note:
If header = True Then: srcrow = 23: Else: srcrow = 24Would be much better off as an
IIf statement:srcrow = IIf(header, 23, 24)Also note, this:
If {boolean-expression} = True Then..is always redundant and can be written as:
If {boolean-expression} ThenWith
header being a Boolean already, there's no need to compare it to a Boolean literal to obtain a {boolean-expression}!One of the most important things to do when you have blocks in your code (
If...End If, For...Next, While...Wend, Do...Loop, but also Sub...End Sub, etc.), is indentation.Here's your function, properly indented:
Function formatrow(roww As Long, header As Boolean)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim headerval As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("DEALSHEET")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Sheets("Sheet1")
srcrow = IIf(header, 23, 24)
LastColumn = sht.Cells(ZROW + 1, sht.Columns.Count).End(xlToLeft).Column
For x = 2 To LastColumn
headerval = sht.Cells(ZROW + 1, x).Value
srccol = srccolbyname(headerval)
sht2.Cells(srcrow, srccol).Copy 'THIS IS SLOW
sht.Cells(roww, x).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next x
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End FunctionNotice how much easier it is to see where the loop starts, where it ends, and what's in its body.
Now sure what
ZROW is, it's not declared in the scope of formatrow so I'm assuming it's a module-scoped constant and that other procedures in that module as using it. If only formatrow uses it, it should be scoped to formatrow.You declared
sht and sht2 as Worksheet objects; you should be querying the Worksheets collection, not Sheets (which contains charts and other sheet types).But then, if these sheets aren't dynamically generated, you shouldn't need to query any worksheet collection and get the objects by their "sheet name" (which the users can change at any time!) - instead, use their "code name": VBA defines a global-scope object for every Excel object (including
ThisWorkbook, but also Sheet1 and every sheet in the workbook), so you can use the Properties toolwindow (F4) to set their (Name) property to a meaningful identifier, and then use that identifier in code, so you can delete all these:Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("DEALSHEET")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Sheets("Sheet1")And then do this (assuming the sheet labelled "DEALSHEET" is named
DealSheet):LastColumn = DealSheet.Cells(ZROW + 1, DealSheet.Columns.Count).End(xlToLeft).ColumnAnd this:
headerval = DealSheet.Cells(ZROW + 1, x).ValueAnd that:
Sheet1.Cells(srcrow, srccol).Copy 'THIS IS SLOWAnd so on.
Now, about performance. You need a radically different approach. How would you do it if you were going to do it manually? Would you Copy+Paste one cell at a time, or Copy+Paste the whole row at once?
You want to copy/paste the formats on
srcrow from column 2 through LastColumn: do that.Sheet1.Range(Sheet1.Cells(srcrow, 2), Sheet1.Cells(srcrow, LastColumn)).Copy
DealSheet.Range(DealSheet.Cells(roww, 2), DealSheet.Cells(roww, LastColumn)) _
.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=FalseNo need to loop, no need to lookup column numbers. Unless I missed something. Should be much faster!
I also ran Rubberduck inspections (build 2.0.10, not released yet). A few things to note:
formatrowis implicitly public. Consider specifying an explicit access modifier.
sht,sht2,strng_nameandxare poor names. Consider renaming them; avoid disemvoweling, numeric suffixes, underscores, type prefixes, and 1-2 character identifiers.
formatrowis aFunction, but its return value is never even assigned so it always returns an implicitVariant/Empty; it should probably be aSub.
- Parameters
roww,header, andstrng_nameare implicitly passed by reference, and can safely be passed by value (ByVal) instead.
- Explicit
Callsyntax is obsolete. Use the implicit call syntax instead (which you've used to callsrccolbynameanyway).
Code Snippets
If header = True Then: srcrow = 23: Else: srcrow = 24srcrow = IIf(header, 23, 24)If {boolean-expression} = True ThenIf {boolean-expression} ThenFunction formatrow(roww As Long, header As Boolean)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim headerval As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("DEALSHEET")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Sheets("Sheet1")
srcrow = IIf(header, 23, 24)
LastColumn = sht.Cells(ZROW + 1, sht.Columns.Count).End(xlToLeft).Column
For x = 2 To LastColumn
headerval = sht.Cells(ZROW + 1, x).Value
srccol = srccolbyname(headerval)
sht2.Cells(srcrow, srccol).Copy 'THIS IS SLOW
sht.Cells(roww, x).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next x
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End FunctionContext
StackExchange Code Review Q#144807, answer score: 2
Revisions (0)
No revisions yet.