How to Optimize Excel VBA Formula - vba

Question

A little background: Been working on a file which is accessible by 80 users (concurrent would probably be 10 at a time). Say the sales team leaders need to activate a button to activate codes below to read from another file (A) with 3 sheets of 20000 records per sheet (A.1, A.2, A.3), to read line by line to match the copy and paste into the current file based on the names of each sales person based on criteria.
It seemed to take a long time as each leader has 20 sales staff and the code seemed to jam excel though ;(
If the file it's reading from consists of about 1000 lines or something, it works pretty smooth though.
Hope someone could enlighten me.
Option Explicit
Sub T1CopyDataFromAnotherFileIfSearchTextIsFound()
'Clear Existing Content
Sheets("4").Cells.ClearContents
Sheets("5").Cells.ClearContents
Sheets("6").Cells.ClearContents
Sheets("7").Cells.ClearContents
Sheets("8").Cells.ClearContents
Sheets("9").Cells.ClearContents
Sheets("10").Cells.ClearContents
Sheets("11").Cells.ClearContents
Sheets("12").Cells.ClearContents
Sheets("13").Cells.ClearContents
Sheets("14").Cells.ClearContents
Sheets("15").Cells.ClearContents
Sheets("16").Cells.ClearContents
Sheets("17").Cells.ClearContents
Sheets("18").Cells.ClearContents
Sheets("19").Cells.ClearContents
Sheets("20").Cells.ClearContents
Sheets("21").Cells.ClearContents
Sheets("22").Cells.ClearContents
Sheets("23").Cells.ClearContents
'Team 1 Content Copy >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim Name1, Name4, Name5, Name6, Name7, Name8, Name9, Name10, Name11, Name12, Name13, Name14, Name15, Name16, Name17, Name18, Name19, Name20, Name21, Name22, Name23 As String
Dim strPath As String
Dim wbkImportFile As Workbook
Dim shtThisSheet As Worksheet
Dim shtImportSheet1 As Worksheet
Dim shtImportSheet2 As Worksheet
Dim shtImportSheet3 As Worksheet
Dim lngrow As Long
Dim strSearchString As String
Dim strImportFile As String
Name1 = Sheets("UserAccessAcc").Range("B3").Value
Name4 = Sheets("UserAccessAcc").Range("B6").Value
Name5 = Sheets("UserAccessAcc").Range("B7").Value
Name6 = Sheets("UserAccessAcc").Range("B8").Value
Name7 = Sheets("UserAccessAcc").Range("B9").Value
Name8 = Sheets("UserAccessAcc").Range("B10").Value
Name9 = Sheets("UserAccessAcc").Range("B11").Value
Name10 = Sheets("UserAccessAcc").Range("B12").Value
Name11 = Sheets("UserAccessAcc").Range("B13").Value
Name12 = Sheets("UserAccessAcc").Range("B14").Value
Name13 = Sheets("UserAccessAcc").Range("B15").Value
Name14 = Sheets("UserAccessAcc").Range("B16").Value
Name15 = Sheets("UserAccessAcc").Range("B17").Value
Name16 = Sheets("UserAccessAcc").Range("B18").Value
Name17 = Sheets("UserAccessAcc").Range("B19").Value
Name18 = Sheets("UserAccessAcc").Range("B20").Value
Name19 = Sheets("UserAccessAcc").Range("B21").Value
Name20 = Sheets("UserAccessAcc").Range("B22").Value
Name21 = Sheets("UserAccessAcc").Range("B23").Value
Name22 = Sheets("UserAccessAcc").Range("B24").Value
Name23 = Sheets("UserAccessAcc").Range("B25").Value
strPath = ThisWorkbook.Path
strImportFile = "Book1.xlsx"
On Error GoTo Errorhandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set wbkImportFile = Workbooks.Open(Filename:=strPath & "\" & strImportFile, ReadOnly:=True, UpdateLinks:=False)
'Account1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'strSearchString = Name1
'Set shtThisSheet = ThisWorkbook.Worksheets("1")
Set shtImportSheet1 = wbkImportFile.Worksheets("6-9 Months")
Set shtImportSheet2 = wbkImportFile.Worksheets("10-24 Months")
Set shtImportSheet3 = wbkImportFile.Worksheets("25-36 Months")
With shtImportSheet1
.Columns("L").Insert
.Columns("L").Insert
End With
'Account4>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name4
Set shtThisSheet = ThisWorkbook.Worksheets("4")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
'With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
'End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
'Account5>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name5
Set shtThisSheet = ThisWorkbook.Worksheets("5")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
'Account6>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name6
Set shtThisSheet = ThisWorkbook.Worksheets("6")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
wbkImportFile.Close SaveChanges:=False
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Sheets("Summary Report View").Select
MsgBox ("Team 1 Cold Call Data Refresh Completed")
End Sub
''>>>>>>>>Account4 onwards to repeat same codes for account 5 - 20..

Answer 1

I'd go retrieving import workbook data sheets data into arrays, thus minimizing import data workbook opening time, and releasing it as soon as possible.
moreover your code has a lot of repetitions and other possible improvements
here follows a possible refactoring of your code to cope with the "data to array" issue and avoiding repetitions:
Sub T1CopyDataFromAnotherFileIfSearchTextIsFound()
Dim Names As Variant ' <--| array that will hold all the "names"
Dim Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant ' <--| arrays that will store ImportFile worksheets data
Dim strPath As String, strImportFile As String, strSearchString As String
ClearSheets '<--|'Clear Existing Content
SetNames Names '<--| set the "names"
'Team 1 Content Copy >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strPath = ThisWorkbook.Path
strImportFile = "Book1.xlsx"
On Error GoTo Errorhandler '<---| where is the label???
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
' here try and read data from import workbook to arrays Months6_9, Months10_24, and Months25_36
If Not ReadImportData(strPath & "\" & strImportFile, Months6_9, Months10_24, Months25_36) Then Exit Sub '<--| exit if reading data unsuccessfully
'Account1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' what was here has been shifted to
'Account4>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(4)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("4"), strSearchString
'Account5>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(5)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("5"), strSearchString
'Account6>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(6)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("6"), strSearchString
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Sheets("Summary Report View").Select
MsgBox ("Team 1 Cold Call Data Refresh Completed")
End Sub
which relies on the following helper subs/functions:
The function that reads import workbook worksheets data and stores them into arrays
Function ReadImportData(wbFullName As String, Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant) As Boolean
Dim wbkImportFile As Workbook
If Dir(wbFullName) = "" Then Exit Function '<--| exit if there's no such file
On Error Resume Next
Set wbkImportFile = Workbooks.Open(Filename:=wbFullName, ReadOnly:=True, UpdateLinks:=False)
On Error GoTo 0
If wbkImportFile Is Nothing Then Exit Function '<--| exit if you couldn't open the workbook
With wbkImportFile
With .Worksheets("6-9 Months")
.Columns("L:M").Insert
Months6_9 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
With .Worksheets("10-24 Months")
Months10_24 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
With .Worksheets("25-36 Months")
Months25_36 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
End With
wbkImportFile.Close SaveChanges:=False
ReadImportData = True
End Function
the sub the process the single Account
Sub Account(Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant, shtThisSheet As Worksheet, strSearchString As String)
PutHeaders shtThisSheet '<--| put headers in passed sheet
ProcessMonths Months6_9, shtThisSheet, strSearchString '<-- process Months6_9 arrayfor passed strSearchString
ProcessMonths Months10_24, shtThisSheet, strSearchString '<-- process Months10_24 array for passed strSearchString
ProcessMonths Months25_36, shtThisSheet, strSearchString '<-- process Months25_36 array for passed strSearchString
End Sub
which on is turn demands the processing of single months-interval to:
Sub ProcessMonths(Months As Variant, shtThisSheet As Worksheet, strSearchString As String)
Dim nRows As Long, nCols As Long, iRow As Long, jCol As Long
nRows = UBound(Months, 1)
nCols = UBound(Months, 2)
ReDim tempArr(1 To nCols) As Variant
With shtThisSheet
For iRow = 1 To nRows
If InStr(1, Months(iRow, 11), strSearchString, vbTextCompare) > 0 Then
For jCol = 1 To nCols
tempArr(jCol) = Months(iRow, jCol)
Next jCol
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(, nCols).Value = tempArr
End If
Next iRow
End With
End Sub
and then the last ones
Sub PutHeaders(shtThisSheet As Worksheet)
shtThisSheet.Range("A1:R1") = Array("memberid", "firstname", "lastname", "country", "ADT", "Team", _
"Lastgamingdt", "Type", "predom", "playStatus", "HostName", "HostLogin", _
"Campaign", "GamingOfferType", "OfferAmount", "Tagcode", "TagcodeDescription", "Comments")
End Sub
Sub ClearSheets()
Dim i As Long
With ThisWorkbook
For i = 4 To 23
.Sheets(CStr(i)).Cells.ClearContents
Next i
End With
End Sub
Sub SetNames(Names As Variant)
With ThisWorkbook.Sheets("UserAccessAcc")
Names = Application.Transpose(.Range("B5:B25").Value)
Names(1) = .Range("B3").Value
End With
End Sub