Speeding up my code

[dpaton05]

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.

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

In column AA

=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.

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)
                            .header = xlYes
                            .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

 

[dpaton05]

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.

 

[dpaton05]

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]

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.

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]

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]

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]

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]

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]

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

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]

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?

 

[offthelip]

No probably not