# Speeding up my code

#### dpaton05

##### Well-known Member
I have a table in my spreadsheet that goes from A-AP. It has visible columns up to column Q. From R to AP are hidden columns. The extra columns are hidden and they are just to work out certain information based on the data entered in the visible columns. For instance, I have a date that is entered in column A and in column Z I have this formula to work out the month the transaction needs to be recorded in based on the requirements of my workplace.
Excel Formula:
=IF(MONTH(A5)=6,"June",TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "mmmm"))

In column AA
Excel Formula:
=TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "yyyy")

That is just 2 of the columns. The table ends at the column AP with other formulas that derive their data from the visible cells

I have a copy procedure that looks at every row in the table and copies information from the row to 2 separate documents. These separate documents are financial year documents, broken up into monthly sheets. Parts of each row in the table are copied to monthly sheets in the 2 documents. For about 100 rows entered in the table, in takes around 5 minutes to run the code. This doesn't seem like I have developed it in the most efficient manner and I am sure it can be executed much faster.

I am still learning vba, so when I had something working, I didn't want to break it again so I left it. Other people helped me with most of it too so I couldn't change parts due to not knowing how.

I am not sure if it can be run faster but could someone look at my code and give a few ideas on how I could speed it up please? I have been told that the more you need to interact with the worksheet, the more it slows down. Maybe I should try and move alot of the additional, hidden columns into vba so it doesn't need to interact with the worksheet so much?

Here is my copy procedure.
You may notice that there is code relating to an hours register file that is commented out. I do not need it anymore at the moment but I may need it later.

VBA Code:
Sub cmdCopy()
'On Error GoTo ErrorMsg
Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
Dim Combo As String, sht As Worksheet, tbl As ListObject
Dim LastRow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long
Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
Application.ScreenUpdating = False

'assign values to variables
Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
Set sht = ThisWorkbook.Worksheets("Costing_tool")
Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
'Check if each row has a date, service and requesting organisation
For Each tblrow In tbl.ListRows
If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
Exit Sub
End If
Next tblrow
For Each tblrow In tbl.ListRows
'Define combo as the month to be recorded in
Combo = tblrow.Range.Cells(1, 26).Value
'If column 8 for the row is blank...
If Not tblrow.Range(1, 8).Value = "" Then
'worker variable is defined as the value in column 8 of the row
worker = tblrow.Range.Cells(1, 8).Value
Else
'otherwise, "not allocated" is assigned to the worker variable.
'this is used in the hours register to identify which sheet to place the hours in
worker = "Not allocated"
End If
'defines HoursRegister as the hours register filename that is stored in column 38 for the row
'HoursRegister = tblrow.Range.Cells(1, 38)
'defines ReportTracking as the report tracking filename that is stored in column 39 for the row
ReportTracking = tblrow.Range.Cells(1, 39)
Select Case Site
Case "Wes"
Select Case tblrow.Range.Cells(1, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
DocYearName = tblrow.Range.Cells(1, 37).Value
Case Else
DocYearName = tblrow.Range.Cells(1, 36).Value
End Select
Case "Riv"
Select Case tblrow.Range.Cells(1, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
DocYearName = tblrow.Range.Cells(1, 42).Value
Case Else
DocYearName = tblrow.Range.Cells(1, 36).Value
End Select

End Select
If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row

'Copy the pricing cells from the quoting tool to the allocation sheet for use in calculating late cancels
Workbooks(DocYearName).Worksheets("sheet2").Range("A4:E12").Value = Data.Range("A4:E12").Value

'With wsHours
'this copies the date column in the tblCosting
'HoursRow = .Range("A" & Rows.Count).End(xlUp).Row
'tblrow.Range(, 1).Copy
'this pastes it into column A of hours register file
'.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'this copies the YP name column in the tblCosting
'tblrow.Range(, 4).Copy
'this pastes it into column B of hours register file
'.Range("B" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'this copies the YP name column in the tblCosting
'tblrow.Range(, 3).Copy
'this pastes it into column A of hours register file
'.Range("C" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'this copies the hours column in the tblCosting
'tblrow.Range(, 9).Copy
'this pastes it into column A of hours register file
'.Range("D" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'End With
With wsTrack
'this copies the date column in the tblCosting
tblrow.Range(, 1).Copy
'this pastes it into column A of hours register file
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'this copies the YP name column in the tblCosting
tblrow.Range(, 4).Copy
'this pastes it into column B of the report tracking file
.Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteFormulasAndNumberFormats
'this copies the YP name column in the tblCosting
tblrow.Range(, 5).Copy
'this pastes it into column A of hours register file
.Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
End With
With wsDst
'This sets column width of request number column so it can be read and is not xxxxx
.Columns("C:C").ColumnWidth = 8

'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
tblrow.Range.Resize(, 7).Copy
'This pastes in the figures in the first 7 columns starting in column A
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
tblrow.Range(, 10).Copy

'This pastes in the figures in the first 7 columns starting in column A
.Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats

'Overwrites the numbers pasted to column I with a formula
.Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
'Overwrites the numbers pasted to column L with a formula
.Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
'Adds currency formatting to total ex gst column
.Columns(8).NumberFormat = "\$#,##0.00"
'Adds Australian date format to date column
'.Range("A:A").NumberFormat = "dd/mm/yyyy"

'sort procedure copied from vba
wsDst.Sort.SortFields.Clear
wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Workbooks(DocYearName).Worksheets(Combo).Sort
'set range to sort of A3 to AO
.SetRange Range("A3:AO" & lr)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Next tblrow
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub

'ErrorMsg:
'    Select Case Err.Number
'        Case 53
'            MsgBox "Enable macros needs to be selected"
'    End Select
End Sub

Last edited by a moderator:

#### dpaton05

##### Well-known Member
Thanks again for your help.

I will review your code later today as I am on my mobile at the moment. I will answer the question you have though.

As these documents are financial year documents, they have sheets of each month of the year. The combo variable loads the monthly sheet name that each row is meant to be written too. Column 26 contains a formula that will give the correct month based on the date of the entry in column 1. Therefore, column 26 will have monthly names in it, such as may or June.

They are written to the same monthly sheet in both documents.

I hope I included everything.

### Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

#### dpaton05

##### Well-known Member
This is the formula in row Z7. It is the same for every other row, just with the reference changed to column A.

=IF(MONTH(A7)=6,"June",TEXT(DATE(YEAR(A7),IF(DAY(A7)<26,MONTH(A7),MONTH(A7)+1),1), "mmmm"))

#### dpaton05

##### Well-known Member
I think that I understand what the code is roughly doing. The syntax all seems pretty foreign to me at the moment, but I guess that over time, you become more familiar with it.

My brain has stopped working and I am unsure how to write the output array to the worksheet. I am pretty sure the next step is to write all the data to the DocYearName workbook and I thought I could work it out by looking at your code for the report tracking part but I can't. I have no idea what to write. I tried to write some code but got stuck with it.

Here is what I wrote.

VBA Code:
Sub cmdCopy3()

Dim ReportTrackingDictionary As Object, LastRow As Long, inarr As Variant, i As Long
' comment define output array but the size of it is defined later
Dim outcolA()
Dim outcolDE()
' Comment: this is where inarr is loaded
inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
'comment : this section of code uses "inarr" as one of the variables
'so it must go AFTER you have loaded inarr from the tblecostng
Set ReportTrackingDictionary = CreateObject("Scripting.dictionary")
For i = 1 To UBound(inarr, 1)
ReportTrackingDictionary(inarr(i, 39)) = inarr(i, 1)
Next i
'comment:  end of section
Dim site As String
site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

' comment now we know the size ofthe input array we can define the size of the output arrays
' because we know they can't be larger than the input array. both have the same number of rows as the input table
ReDim outcolA(1 To UBound(inarr, 1), 1 To 1) ' this is one column wide
ReDim outcolDE(1 To UBound(inarr, 1), 1 To 2) ' this is two columns wide
For i = 1 To UBound(inarr, 1)
Select Case site
Case "Wes"
Select Case inarr(i, 6)
'                    Select Case tblrow.Range.Cells(1, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
'DocYearName = tblrow.Range.Cells(1, 37).Value
DocYearName = inarr(i, 37)
Case Else
'DocYearName = tblrow.Range.Cells(1, 36).Value
DocYearName = inarr(i, 36)
End Select
Case "Riv"
'Select Case tblrow.Range.Cells(1, 6).Value
Select Case inarr(i, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
DocYearName = inarr(i, 42)
Case Else
DocYearName = inarr(i, 36)
End Select
End Select

Dim DocYearNameDictionary As Object
Set DocYearNameDictionary = CreateObject("scripting.dictionary")
For i = 1 To UBound(inarr, 1)
DocYearNameDictionary(DocYearName) = inarr(i, 1)
Next i
Next i

Dim RTkey As Variant
For Each RTkey In ReportTrackingDictionary.keys
If Not isFileOpen(RTkey & ".xlsm") Then Workbooks.Open ThisWorkbook.Path _
& "\" & "Report Tracking" & "\" & site & "\" & RTkey & ".xlsm"
' commnet set up index for output array
indi = 1
For i = 1 To UBound(inarr, 1)
' comment check to see if this line of tblcosting needs to be written to the file we have got open
If inarr(i, 39) = RTkey Then
' write the data out to the output array

outcolA(indi, 1) = inarr(i, 1) 'this copies the first column in the tblCosting to col A
outcolDE(indi, 1) = inarr(i, 4) 'this copies the 4th column in the tblCosting to Col D
outcolDE(indi, 2) = inarr(i, 5) 'this copies the 5th column in the tblCosting to Col E
' increment the output index
indi = indi + 1
End If
Next i
' write the output array to worksheet

Next RTkey

' this is seven columns wide
Dim OutColAG(1 To UBound(inarr, 1), 1 To 7)
Dim DYNkey As Variant
For Each DYNkey In DocYearNameDictionary.keys
If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path _
& "\" & "Work Allocation Sheets" & "\" & site & "\" & DocYearName & ".xlsm"
' commnet set up index for output array
indi = 1
For i = 1 To UBound(inarr, 1)
' comment check to see if this line of tblcosting needs to be written to the file we have got open
If inarr(i, 39) = DYNkey Then
' write the data out to the output array
OutColAG(indi, 1 - 7) = inarr.cells((i, 1),(i,7))

End Sub

#### offthelip

##### Well-known Member
Before writing the code to write the data out to the worksheet we must sort out the Combo, monthly sheet problem.
there are two ways we can solve this:
The complicated solve this in exactly the same way as we solved the report tracking filename problem.
i.e We define another array just like DYNames I mentioned in post 42 which we haven't implemented yet. In fact the best of doing this is to have one array with two entries the first being the name of the file for docyearnames and the second the name of the monthly sheet.
Then we need yet another dictionary where we loop through inarr and enter the the monthly names into a worksheetname dictionary. If the names change at all this is more robust
An alternative to this would be to always loop through all the month names . This would be easier to code and we wouldn't need the new dictionary, obviously if a month wasn't needed nothing would be copied. This does mean that if the sheet names change then you would need to change the code because the the names are hard coded. However since you are using an equation this shouldn't be a problem. So i would suggest using this second method. This requires you to add an extra 3rd loop looping through inarr and checking which sheet each row needs to be copied to. This loop need to set up a loop of 12 sheetnames, which you do with a constant array.

#### dpaton05

##### Well-known Member

You might need to help me a little with this bit please as I have no idea what approach to use or even how I am meant to code this.

#### dpaton05

##### Well-known Member
I see that you recommend using the second method you have described, so I guess I will use that method but I am not sure how to code it.

#### dpaton05

##### Well-known Member

You say that the first method you suggested would be harder to code but would the code run faster if you did it that way?

#### offthelip

##### Well-known Member
I have updated the code to add in the loop needed to select the correct monthly worksheet. I have tidied up the code a bit ,getting rid of unnecessary loops and moving things into the correct place.
It is impossible to tell if the code as written is going to be faster than using a "month" dictionary because it depends on the number of month sheets that need to be selected. if it usually only 1 month then a dictionary is probably faster , if it is 12 then the simple code I have written is faster. You may need to change the text in the month name array right at the top of the code, because I don't know what your sheets are called, these must be exactly the same as the sheet names
VBA Code:
Sub cmdCopy3()
' declare Month name array, these names must be the saem as the sheet names in column 26 of  your table
mon = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

Dim ReportTrackingDictionary As Object, LastRow As Long, inarr As Variant, i As Long
' comment define output array but the size of it is defined later
Dim outcolA()
Dim outcolDE()
Set ReportTrackingDictionary = CreateObject("Scripting.dictionary")
Dim DocYearNameDictionary As Object
Set DocYearNameDictionary = CreateObject("scripting.dictionary")

'comment:  end of section
Dim site As String
site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
'    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Comment: this is where inarr is loaded
inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
' comment now we know the size ofthe input array we can defein the size of the output arrays
' because we know they can't be larger than the input array. both have the same number of rows as the input table
ReDim outcolA(1 To UBound(inarr, 1), 1 To 1) ' this is one column wide
ReDim outcolDE(1 To UBound(inarr, 1), 1 To 2) ' this is two columns wide
For i = 1 To UBound(inarr, 1)
ReportTrackingDictionary(inarr(i, 39)) = inarr(i, 1)

Select Case site
Case "Wes"
Select Case inarr(i, 6)
'                    Select Case tblrow.Range.Cells(1, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
'DocYearName = tblrow.Range.Cells(1, 37).Value
DocYearName = inarr(i, 37)
Case Else
'DocYearName = tblrow.Range.Cells(1, 36).Value
DocYearName = inarr(i, 36)
End Select
Case "Riv"
'Select Case tblrow.Range.Cells(1, 6).Value
Select Case inarr(i, 6).Value
Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
DocYearName = inarr(i, 42)
Case Else
DocYearName = inarr(i, 36)
End Select
End Select

DocYearNameDictionary(DocYearName) = DocYearName
Next i

Dim RTkey As Variant
For Each RTkey In ReportTrackingDictionary.Keys
If Not isFileOpen(RTkey & ".xlsm") Then Workbooks.Open ThisWorkbook.Path _
& "\" & "Report Tracking" & "\" & site & "\" & RTkey & ".xlsm"
' set  up loop to check each monthly sheet
For mn = 1 To 12
Combo = mon(mn)
' commnet set up index for output array
indi = 1
For i = 1 To UBound(inarr, 1)
' comment check to see if this line of tblcosting needs to be written to the file we have got open
If inarr(i, 39) = RTkey And inarr(i, 26) = Combo Then
' write the data out to the output array
outcolA(indi, 1) = inarr(i, 1) 'this copies the first column in the tblCosting to col A
outcolDE(indi, 1) = inarr(i, 4) 'this copies the 4th column in the tblCosting to Col D
outcolDE(indi, 2) = inarr(i, 5) 'this copies the 5th column in the tblCosting to Col E
' increment the output index
indi = indi + 1
End If
Next i
' write the output array to worksheet
if indi > 1 then
With Worksheets(Combo)
Range(.Cells(1, 1), .Cells(indi, 1)) = outcolA
Range(.Cells(1, 4), .Cells(indi, 5)) = outcolDE
End With
end if
Next mn
Next RTkey

End Sub

#### dpaton05

##### Well-known Member
Thank you so much again for your help. The code looks like it is logically correct but I can't test it until Friday. I will let you know how it goes.

Would there be much of a difference in execution time between the two methods?

No probably not

Replies
0
Views
102
Replies
8
Views
151
Replies
4
Views
108
Replies
0
Views
39
Replies
4
Views
126