Question

一点背景：正在处理一个可由80个用户访问的文件（并发可能一次只有10个）。假设销售团队负责人需要激活一个按钮来激活下面的代码，从另一个文件（A）中读取每张3张20000条记录（A.1，A.2，A.3），逐行读取根据标准，根据每个销售人员的姓名将复制和粘贴匹配到当前文件中。

似乎需要很长时间，因为每个领导者都有20名销售人员，但代码似乎更加出色;（

如果它所读取的文件包含约1000行或其他内容，则它的工作非常顺畅。

希望有人能够启发我。

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

我将导入工作簿数据表数据检索到数组中，从而最大限度地减少导入数据工作簿的打开时间，并尽快释放它。

此外，您的代码有很多重复和其他可能的改进

下面是一个可能的重构代码，以应对＆＃34;数据到数组＆＃34;问题并避免重复：

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

依赖于以下助手子/函数：

读取导入工作簿工作表数据并将其存储到数组中的函数

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

子过程单个账户

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

转而要求将单个月间隔处理为：

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

然后是最后的

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

如何优化Excel VBA公式

1 个答案: