VBA script that copies data from one workbook to another 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) &lt;&gt; 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 &lt; 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 &lt;&gt; -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!
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 &lt; 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)) &gt; 0 Then
                Key = Replace(.Cells(r, 3).Value2, "_", "") &amp; "|" &amp; .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)) &gt; 0 Then
                Key = Replace(.Cells(r, 3).Value2, "_", "") &amp; "|" &amp; .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