如何优化Excel 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:

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

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

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