# 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) <> 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!

## Option Explicit

The counter variables were never declared.

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.

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

• Wow, thank you! I didn't realize Dictionary's existed in VBA (very new to it). That makes things a million times easier. As for the K loop you've made me feel like a right numpty :) You're a beauty TinMan – ConBob Jun 28 '18 at 19:12
• I kinda figured that the K =5 function changed as you worked out the code. No harm meant. Just a little tough love ;) – TinMan Jun 28 '18 at 19:18

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.

I found something a little awkward that I would do differently

  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

• Good catch, definitely helps make that section look nice. – ConBob Jun 28 '18 at 16:03
• I think that it may make that a little more efficient, I was looking at doing something similar with the other 2 loops, but they are a little different than the inside loop. – Malachi Jun 28 '18 at 16:09