VBA script that copies data from one workbook to another

Question

I've written a perl script that creates a csv file consolidated of values from multiple files. This file that I've created is then used to update certain rows in a main excel spreadsheet my company uses. I've created a VBA script that scans the main file for values that match up with those from my perl generate file and it all works fine.

The problem is that it takes about four minutes to run. The main file is only about 1000 or so rows long, and the file I'm generating only comes out to about 100 rows top. My logic in my script is to scan through every row in the main file for each row in the generated file:

Sub TransferDataToForecast()
  Dim strPath As String  'File path
  Dim foreb As Workbook  'Workbook that the file path points to
  Dim copys As Worksheet 'Worksheet that contains the data to be copied
  Dim dests As Worksheet 'Worksheet that is being copied to
  Dim copysLastRow As Long 'Last row of data worksheet
  Dim copysLastCol As Long 'Last column of data worksheet
  Dim destsLastRow As Long 'Last row of target worksheet
  Dim counter As Long      'Counter for loop control

  Application.ScreenUpdating = False
  Set copys = ActiveWorkbook.ActiveSheet

  'Get user to select target workbook
  strPath = BrowseForFile("Select the DM Forecast file you want to update")
  If strPath = vbNullString Then Exit Sub

  'Debug.Print strPath
  Set foreb = Workbooks.Open(strPath)
  Set dests = foreb.Worksheets("Material_Usage_Prim")

  'Get last row of each worksheet and last column of data sheet in order to help with loop control
  copysLastRow = copys.Cells(Rows.Count, 3).End(xlUp).Row
  copysLastCol = copys.Cells(2, Columns.Count).End(xlToLeft).Column
  destsLastRow = dests.Cells(Rows.Count, 1).End(xlUp).Row
  counter = 0

  'Loop through each row of the data sheet
  For i = 2 To copysLastRow
  Debug.Print "i is "; i
  'For each row in the data sheet, loop through every row in the destination sheet in order
  'to find matching id's between each sheet
    For j = 2 To destsLastRow
      Debug.Print "j is "; j
      If Trim(copys.Cells(i, 3).Value2) = vbNullString Then Exit For   'This exits the loop if the data sheet has a blank row
      If dests.Cells(j, 4) <> copys.Cells(i, 4) Then GoTo NextDestLoop 'This skips the rest of the current j if values in col4 of each sheet don't match up

      'Have to use replace due to differing naming conventins among people i.e. _ vs - (this row can be changed for specific peoples needs)
      'This checks that columns 3 and 4 of each sheet match
      If Replace(copys.Cells(i, 3).Value2, "_", "") = Replace(dests.Cells(j, 3).Value2, "_", "") And copys.Cells(i, 4).Value2 = dests.Cells(j, 4).Value2 Then
        counter = 0
        For k = 5 To copysLastCol
            Debug.Print "k is "; k
            'Go to 14, because we want to keep the first 14 weeks (columns)
            If counter < 14 Then
                counter = counter + 1
                GoTo NextIteration
            End If
            counter = counter + 1
            dests.Cells(j, k).Value2 = copys.Cells(i, k).Value2
     NextIteration:
            Next k
      End If
      If counter = copysLastRow Then GoTo NextLoop
   NextDestLoop:
    Next j
NextLoop:
  Next i

  Application.ScreenUpdating = True
  MsgBox ("Data has been transferred.")
End Sub

'This function brings up a window for the user to pick an excel file they want to update
Private Function BrowseForFile(Optional strTitle As String) As String
  Dim fDialog As FileDialog
    On Error GoTo Err_handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo Err_handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With

lbl_Exit:
    Exit Function
Err_handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

If anyone can help me to make this more efficient I would be grateful!

Answer 1

Option Explicit

The counter variables were never declared.

MSDN Option Explicit Statement:

Note Use Option Explicit to avoid incorrectly typing the name of an existing variable or to avoid confusion in code where the scope of the variable is not clear.

Goto Statement

Goto Statement are best reserved for error handling.

MSDN Goto Statement:

Note Too many GoTo statements can make code difficult to read and debug. Use structured control statements ( Do...Loop, For...Next, If...Then...Else, Select Case ) whenever possible.

ID Lookups

Using nested loops over multiple lists comparing unique values (IDs) is very inefficient. Use a Dictionary. They are optimised to reference IDs stored as Key/Value pairs.

K Loop

        Debug.Print "k is "; k
        'Go to 14, because we want to keep the first 14 weeks (columns)
        If counter < 14 Then
            counter = counter + 1
            GoTo NextIteration
        End If
        counter = counter + 1
        dests.Cells(j, k).Value2 = copys.Cells(i, k).Value2
 NextIteration:
        Next k

Why would you not just start K at 14?????

Refactored Code

Using a Dictionary to store value Arrays by key ID, this code took 11.27 seconds to transfer 10K rows x 12 Columns of data. I better computer would easily cut that time in helf. My IndexedArray Class takes about 0.6 seconds per 10K Rows x 7 Columns.

Sub TransferDataToForecast2()
    Dim r As Long, c As Long
    Dim Key As Variant, Values As Variant
    Dim strPath As String
    Dim dicID As Object
    Set dicID = CreateObject("Scripting.Dictionary")

    'Get user to select target workbook
    strPath = BrowseForFile("Select the DM Forecast file you want to update")
    If strPath = vbNullString Then Exit Sub

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    With ActiveWorkbook.ActiveSheet                   'Worksheet that contains the data to be copied

        For r = 2 To .Cells(Rows.Count, 3).End(xlUp).Row
            If Len(Trim(.Cells(r, 3).Value2)) > 0 Then
                Key = Replace(.Cells(r, 3).Value2, "_", "") & "|" & .Cells(r, 4).Value2
                If dicID.Exists(Key) Then
                    Debug.Print "Duplicate ID Found:"; .Name; " - "; .Cells(r, 3).Address
                Else
                    ' Add the ID and Array of Values
                    Values = .Range(.Cells(r, 14), .Cells(r, .Columns.Count).End(xlToLeft)).Value
                    dicID.Add Key, Values
                End If
            End If
        Next
    End With

    With Workbooks.Open(strPath).Worksheets(1)
        For r = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
            If Len(Trim(.Cells(r, 3).Value2)) > 0 Then
                Key = Replace(.Cells(r, 3).Value2, "_", "") & "|" & .Cells(r, 4).Value2
                If dicID.Exists(Key) Then
                    Values = dicID(Key)
                    .Cells(r, 14).Resize(1, UBound(Values, 2)).Value2 = Values
                End If
            End If
        Next
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox ("Data has been transferred.")
End Sub

Answer 2

One thing that is hurting performance in your code is that you are constantly accessing cells in the two worksheets. This always incurs the cost of a context switch between Excel and the VBA runtime. To avoid this, you can load the entire ranges you are interested in into a 2d array by assigning the range's Value or Value2 property to a Variant variable. Then you can perform all the checks and modifications on the arrays and finally write the entire destination range back by assigning the corresponding 2d array to the target range's Value or Value2 property. This will avoid most context switches.

Since this is CR, I will also comment a bit about the coding style.

The thing that sprung to my eye first is that you use a lot of magic numbers and hard-coded things. For maintainability it would certainly not hurt to save these in properly named constants, in particular the characters in the Replace calls. These could actually be parameters passed into the sub.

In the case of the range's in the Excel sheets accessed explicitly, it might be advantageous to use named ranges. That would the possibility for any trouble should the layout of one of the sheets change.

Another thing that might increase the maintainability of the code is to actually use meaningful names. There really is no reason to favor shortness over expressiveness. In particular, good names for the loop counters would make the code much easier to read.

There is probably more, both in the performance and the style department that could be said, but I will leave it at this.

Answer 3

I found something a little awkward that I would do differently

your code

  If Replace(copys.Cells(i, 3).Value2, "_", "") = Replace(dests.Cells(j, 3).Value2, "_", "") And copys.Cells(i, 4).Value2 = dests.Cells(j, 4).Value2 Then
    counter = 0
    For k = 5 To copysLastCol
        Debug.Print "k is "; k
        'Go to 14, because we want to keep the first 14 weeks (columns)
        If counter < 14 Then
            counter = counter + 1
            GoTo NextIteration
        End If
        counter = counter + 1
        dests.Cells(j, k).Value2 = copys.Cells(i, k).Value2
 NextIteration:
        Next k
  End If

A lot of programmers do not like the use of GoTo to begin with, and this situation is not a situation in which you absolutely have to use it. instead you should use a Greater Than or Equal too operator to perform the operation that you want to do when the counter is 14 or over, then move the counter incrementation outside of the if statement. This removes the GoTo entirely and performs the same operation.

If Replace(copys.Cells(i, 3).Value2, "_", "") = Replace(dests.Cells(j, 3).Value2, "_", "") And copys.Cells(i, 4).Value2 = dests.Cells(j, 4).Value2 Then
  counter = 0
    For k = 5 To copysLastCol
        Debug.Print "k is "; k
        'Go to 14, because we want to keep the first 14 weeks (columns)     
        If counter >= 14 Then
            dests.Cells(j, k).Value2 = copys.Cells(i, k).Value2
        End If
        counter = counter + 1
    Next
End If