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 for that.

I just want to ensure I have the correct understanding,

With this line, can you please correct me if I am wrong,

ReDim outcolA(1 To UBound(inarr, 1), 1 To 1)

This Is defining the size of the array as it couldn't be set before inarr was defined. The size of the output array starts at 1 and ends at the upper limit of inarr. The 1 To 1 at the end is referring to one column.

I am struggling with what the first 1 means or does. I think this is how many dimensions the array has but what does that mean?

Thanks again for your help ?

 

[offthelip]

You are correct in your analysis, the indexing of a variant array can start at zero or at 1 ( actually it can start at anything) , you have to define it as starting some where and set up your indexing to start at the same point. If you load a variant array from a range (as we have done with inarr) thje indexing will automatically start at 1. This is really convenient if you load you array starting at A1 i.e Cells (1,1) because then the indexing of the array has the same numbers as the row and column numbers. So I almost always load input arrays from A1 to make the indexing easy. As an example there are two way of loading an array to check values in B3 to B20:
the easy way :

Inarr=Range(cells(1,1),cells(20,2))
for i= 3 to 20
 if inarr(i,2)=TRUE then 
etc

the more complex way but does load a smaller array:

inarr= range(cells(2,3),cells(2,20))
for i = 1 to 18
if inarr(i,1) = TRUE then
etc

Note these two bits of code check exactly the same values from the worksheet

 

[dpaton05]

Thanks for that. What I meant to say was I don't understand what second 1 is for.

ReDim outcolA(1 To UBound(inarr, 1), 1 To 1)

I think it is the dimension but every resource I can find online does not explain what a dimension is in a way that makes sense to me.

 

[dpaton05]

Could you try and explain it to me please?

 

[offthelip]

A list is one dimensional array e.g.
Apples, Oranges,Pears,Bananas
You can store this list in a series of column on a single row of an excel spreadsheet , ort you could store it in a series of rows in a single column on an excel spreadsheet
In my code I defined a single dimensional array to define the Name of each monthly sheet:

mon = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

note that when I reference I only use a single index:

This is because it only has one index going from 0 to 11

Say you now add a price and a quantity to each of these items

Name​	Price​	Quantity​
Apples​	1.2​	5​
Oranges​	1.3​	7​
Pears​	12.5​	6​
Bananas​	0.8​	8​

Here you need some way of laying out the data so that you can see the correlation between one column and the next.
This is a two dimensional array. i.e. A EXCEL worksheet is always a two dimensional array because it has got rows and columns
We can load this data into a variant array using the statement

Inarr=range (cells(1,1),cells(5,3))

Then we can refer to the price of pears, as “inarr(4,2) “ e.g. 4th Row , 2nd column. To refer to any value I have to give two indices ( e.g. row and a column)

Now say we keep a record of prices and quantities for each fruit every month for a year. We have 12 sets data each describing a fruit , a quantity and a price.
Excel doesn’t have any 3 dimensional constructs so the only way to store this is in 12 separate two dimensional worksheets.

However we could load it into a 3 dimensional variant array, this code does exactly that:

Sub load3darray()
mon = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Dim threedimArr(0 To 11, 1 To 5, 1 To 3)
For monno = 0 To 11
   Worksheets(mon(monno)).Select
    inarr = Range(Cells(1, 1), Cells(5, 3))
    For i = 1 To 5
     For j = 1 To 3
      threedimArr(monno, i, j) = inarr(i, j)
     Next j
    Next i
Next monno
End Sub

This could be useful is we are needing some code which will return the price of a fruit in a particular month, i.e you input the fruit type and the month and you get the price and quantity back for that fruit and month.

Now let us make it more complicated by saying this 3D table is just the price from one supplier now we add 4 different suppliers. Assume we have a separate workbook for each supplier We now make or array a 4 dimensional array, by adding yet another loop around the workbooks and making our array 4 dimensional. So now to find the price of a fruit I need 3 pieces of information, the fruit , the month and the supplier. this goes on for ever there is no limit to the number of dimensions you can create, proved you stay within the maximum limit EXCEL puts on rows, column etc.

in my statement

ReDim outcolA(1 To UBound(inarr, 1), 1 To 1)

I have defined a two dimensional array ( because there are two set of indices. The first is from 1 to (UBound(inarr,1) which just makes the first index the same size as the first index in inarr
The second index is defined as 1 to 1. What this is saying is: this is a two dimensional array but with only 1 column in the second dimension. This is appears to be slightly weird because you might think that a single dimensional array would be as good. In many cases that is true, however as I said earlier EXCEL spreadsheets are always 2 dimensional object. So if you want to write a variant array directly to the worksheet it must be a a 2 dimensional array. thus I declare outcolA to be a 2 D array with just 1 column width
I hope this helps

 

[dpaton05]

Thanks for that explanation. I have not had time to look closely at it yet as I am at work now and I have realised that you have removed some additional code I had in the original procedure. There are processes that ran in addition to the procedure I have described to you. It was working as intended before I altered any of the code at the start of this thread, the only problem was it was slow.

I have looked at the code and tried to adjust it by putting the code I wrote back in but as I do not really understand what the code you wrote does, I had trouble doing that. Post 46 has all the required code for the additional things to run. Could you add in your most recent update to the procedure in post 46 please?

 

[offthelip]

Can I remind you of what you said in post #47:

I would also love to learn how to make your other method of completing this project that you mentioned in post 42 that you thought would be so much faster.

I am happy to help you learn which is what I have been trying to do, but I don't feel inclined to just write the code for you. I made some easy code improvements which improved the run time significantly. I never intended to do a complete restructure and rewrite. However I have shown you the way I would do it and if you understand what we have written so far, there is nothing different that needs to be added to complete the task, only the same techniques using different files and the other dictionary. .
I suggest you try running the code that you currently have using the dictionary approach, debug that and find out how it works. Then you will be in a position to complete the rest of it.

 

[dpaton05]

I will look into it when I get back to work. Thanks for reminding me that I want to learn this. ?

 

[dpaton05]

Thanks for your help in understanding arrays. I am happy with the speed of my procedure now. Could you please send me a private message with the url of this thread in it?

Thanks