需要提高代码性能：代码编译一个工作簿中的多个选项卡，然后对多个工作簿重复该过程

Question

我的数据分布在 90 个客户的 90 个 Excel 文件中。每个文件大约有 50 张。每张表都包含来自特定团队的客户数据。每个工作表可以有多行具有相同的客户 ID。第 1 行有标题，后面的行有客户数据。

注意

1. 客户档案页数不同，不一致。团队名称相同，因此选项卡名称相同，但编号不同。
2. 两个客户之间的同一团队选项卡的列数可能不同。同样，如果存在列标题，则它们是相同的。计数可能会有所不同

我写了一段代码 -

1. 通过用户输入文件，并保存为strfile变体。打开第一个客户档案。
2. 将跨选项卡的数据编译到单个选项卡“编译”中。第 1 行：选项卡名称，第 2 行：标题名称，第 3+ 行：数据集
3. “编译”选项卡被复制到父文件中并重命名为客户 ID。关闭客户档案。
4. 为“key”添加新行作为选项卡名称_标题名称。将其粘贴为值。
5. 更新每个客户 ID 的“仪表板选项卡”中的选项卡计数和标题计数
6. 打开下一个客户档案。
7. 重复步骤2-5

我的代码可以工作，但需要花费大量时间来编译每个客户文件。如果有人能帮助我快速完成，将会有很大的帮助。

PS。该代码还有一个进度条。

Sub CustomerCompile()

Dim wbcompile As Workbook
Dim wbCust As Workbook
Dim strfile As Variant
Dim w As Integer
Dim wb_count As Integer

'delete current tabs
    Set wbcompile = ActiveWorkbook
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        If (ws.Name <> "Dashboard" And ws.Name <> "Customer Dataset") Then ws.Delete
    Next
    Application.DisplayAlerts = True
    
'delete dashboard table for tabs
    With wbcompile.Sheets("Dashboard").ListObjects("CustomerDetails")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.Delete
        End If
    End With
    
    
    
    'wbcompile.Sheets("Dashboard").Range("CustomerDetails").Select
        'ActiveCell.Offset(1, 0).Select
        'Range(Selection, Selection.End(xlToRight)).Select
        'Range(Selection, Selection.End(xlDown)).Select
     '   Selection.ClearContents
    
'Open dialog box to select customer files
    strfile = Application.GetOpenFilename(FileFilter:="Excel files (*.xlsx*),*.xlsx*", Title:="Choose customer profiles to pull", MultiSelect:=True)

'Compile customer profile data in single tab
        
        UserForm1.Show
        Dim t As Integer
        t = 0
        
    For w = LBound(strfile) To UBound(strfile)
        Workbooks.Open strfile(w)
        Set wbCust = ActiveWorkbook

        Dim ws_Count As Integer
        Dim I As Integer
        Dim ShtNm As String
        Dim ReqID As String
        
        Sheets.Add
        ActiveSheet.Move Before:=ActiveWorkbook.Sheets(1)
        ActiveSheet.Name = "Compile"

        'Set WS_Count equal to the number of worksheets in the active workbook.
        ws_Count = ActiveWorkbook.Worksheets.Count

        'Begin the loop.
        For I = 2 To ws_Count
            Worksheets(I).Select
            ShtNm = ActiveSheet.Name
            'Debug.Print ShtNm
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            Range("A2").Select
            Selection.End(xlToRight).Select
            Selection.End(xlUp).Select
            ActiveCell.Value = ShtNm
            ActiveCell.Copy
            Range(Selection, Selection.End(xlToLeft)).Select
            ActiveSheet.Paste
            Selection.End(xlToLeft).Select
            Selection.End(xlUp).Select
            'Range(Selection, Selection.End(xlToRight)).Select
            'Range(Selection, Selection.End(xlDown)).Select
            
            ActiveSheet.UsedRange.Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Compile").Select
            Range("XFD1").Select
            Selection.End(xlToLeft).Select
            ActiveCell.Offset(0, 1).Select
            ActiveSheet.Paste
            Worksheets(I).Select
            Rows("1:1").Select
            Selection.Delete Shift:=xlUp
            'MsgBox ActiveWorkbook.Worksheets(I).Name
            t = t + 1
            Debug.Print "Customer: " & w & "/" & UBound(strfile) & "; Overall Completed: " & Format(t / (UBound(strfile) * ws_Count) * 100, "#.0")
            UserForm1.Label2.Width = UserForm1.Label1.Width * t / (UBound(strfile) * ws_Count)
            UserForm1.Label3.Caption = Format(t / (UBound(strfile) * ws_Count) * 100, "#.0") & "% completed."


        Next I
        ReqID = ActiveWorkbook.Sheets("BASIC DATA").Range("a2").Value
        Sheets("Compile").Select
        Columns("A:A").Select
        Selection.Delete Shift:=xlLeft
        Dim wscust As Worksheet
        Set wscust = ActiveWorkbook.Sheets("Compile")
        wscust.Copy After:=wbcompile.Sheets(wbcompile.Sheets.Count)
        ActiveSheet.Name = ReqID
        wbCust.Close SaveChanges:=False
        'MsgBox ActiveWorkbook.Worksheets(ReqID).Name & " Imported"
        
        'Adding header key
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
        Range("A2").Select
        Selection.End(xlToRight).Select
        Selection.End(xlUp).Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=R[1]C&""_""&R[2]C"
        Selection.End(xlUp).Select
        Selection.Copy
        Range(Selection, Selection.End(xlToLeft)).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Selection.End(xlToLeft).Select
        Dim Row_Count As Integer
        Row_Count = Cells.CurrentRegion.Rows.Count
        ActiveSheet.Range("A4").Copy
        ActiveSheet.Range("A5:A" & Row_Count).Select
        ActiveSheet.Paste
        'MsgBox Row_Count
        
        'Adding #Profile_Section and #Header
        Dim Section_count As Integer
        Dim Header_count As Integer
        Dim Profile_Section As Range
        Set Profile_Section = Worksheets(ReqID).Range("2:2")
        Header_count = Worksheets(ReqID).Range("3:3").Cells.SpecialCells(xlCellTypeConstants).Count
        wbcompile.Activate
        
        ActiveWorkbook.Sheets("Dashboard").Range("Cust_num").Offset(w, 0).Value = w
        ActiveWorkbook.Sheets("Dashboard").Range("Tab_name").Offset(w, 0).Value = ReqID
        ActiveWorkbook.Sheets("Dashboard").Range("Profile_Sections").Offset(w, 0).Value = Unique(Profile_Section) - 1
        ActiveWorkbook.Sheets("Dashboard").Range("Headers").Offset(w, 0).Value = Header_count
        
    Next w

UserForm1.Label2.Width = UserForm1.Label1.Width
UserForm1.Label3.Caption = "100.0% completed."
'Unload UserForm1
Beep
Worksheets("Dashboard").Activate
ActiveWorkbook.Save

End Sub
Function Unique(Profile_Section As Range) As Integer
    Dim rng As Range
    Dim List As Object
    Set List = CreateObject("Scripting.dictionary")
    For Each rng In Profile_Section
        If Not List.exists(rng.Value) Then List.Add rng.Value, Nothing
    Next
    Unique = List.Count
        
End Function

Answer 1

一些改进建议（已编译但未测试）：

Option Explicit

Sub CustomerCompile()

    Dim wbCompile As Workbook, ws As Worksheet, wsCompile As Worksheet
    Dim wbCust As Workbook, cDest As Range
    Dim strfile As Variant, rngCopy As Range, loDash As ListObject
    Dim w As Long, lastCol As Long
    Dim frm As UserForm1
    Dim ws_Count As Long, I As Long
    Dim ShtNm As String, ReqID As String
    
    'speed up...
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    'delete current tabs
    Set wbCompile = ActiveWorkbook
    Application.DisplayAlerts = False
    For Each ws In wbCompile.Worksheets
        If (ws.Name <> "Dashboard" And ws.Name <> "Customer Dataset") Then ws.Delete
    Next
    Application.DisplayAlerts = True
    
    'delete dashboard table for tabs
    Set loDash = wbCompile.sheets("Dashboard").ListObjects("CustomerDetails")
    If Not loDash.DataBodyRange Is Nothing Then loDash.DataBodyRange.Delete
    
    'Open dialog box to select customer files
    strfile = Application.GetOpenFilename(FileFilter:="Excel files (*.xlsx*),*.xlsx*", _
                         Title:="Choose customer profiles to pull", MultiSelect:=True)

    'Compile customer profile data in single tab
    Set frm = New UserForm1 'don't use the default form instance....
    frm.Show
    Dim t As Integer
    t = 0
        
    For w = LBound(strfile) To UBound(strfile)
        
        Set wbCust = Workbooks.Open(strfile(w), ReadOnly:=True)
        
        'insert a new sheet in this workbook and name it
        Set wsCompile = wbCompile.Worksheets.Add( _
                   after:=wbCompile.Worksheets(wbCompile.Worksheets.Count))
        ReqID = wbCust.sheets("BASIC DATA").Range("a2").Value
        wsCompile.Name = ReqID
        Set cDest = wsCompile.Range("A1") 'start adding here on the new sheet...

        'Begin the loop.
        For I = 2 To wbCust.Worksheets.Count
            
            Set ws = wbCust.Worksheets(I) 'reference the source sheet
            ShtNm = ws.Name
            
            Set rngCopy = ws.UsedRange 'data on `ws` to copy
            
            cDest.Resize(1, rngCopy.Columns.Count).Value = ShtNm 'add the sheet name
            cDest.Offset(1).Resize(rngCopy.Rows.Count, _
                                   rngCopy.Columns.Count).Value = rngCopy.Value 'directly copy the data
            
            Set cDest = cDest.Offset(0, rngCopy.Columns.Count) 'next paste position
            
            t = t + 1
            Debug.Print "Customer: " & w & "/" & UBound(strfile) & _
                   "; Overall Completed: " & Format(t / (UBound(strfile) * ws_Count) * 100, "#.0")
            frm.Label2.Width = frm.Label1.Width * t / (UBound(strfile) * ws_Count)
            frm.Label3.Caption = Format(t / (UBound(strfile) * ws_Count) * 100, "#.0") & "% completed."
        
        Next I
       
        wbCust.Close SaveChanges:=False
        
        'Adding header key by combining rows 2 and 3
        wsCompile.Rows(1).Insert Shift:=xlDown
        lastCol = wsCompile.Cells(2, wsCompile.Columns.Count).End(xlToLeft).Column
        With wsCompile.Range("A1", wsCompile.Cells(1, lastCol))
            .Formula = "=A2 & ""_"" & A3"
            .Value = .Value 'convert formulas to values
        End With
        'fill down the value from A4
        wsCompile.Range("A5:A" & wsCompile.UsedRange.Rows.Count).Value = wsCompile.Range("A4").Value
        
        'Add info to a new row in the listobject on Dashboard
        With loDash.ListRows.Add.Range
            .Cells(1).Value = w
            .Cells(2).Value = ReqID
            .Cells(3).Value = Unique(wsCompile.Rows(2)) - 1
            .Cells(4).Value = wsCompile.Rows(3).Cells.SpecialCells(xlCellTypeConstants).Count
        End With
        
    Next w

    frm.Label2.Width = frm.Label1.Width
    frm.Label3.Caption = "100.0% completed."
    'Unload UserForm1
    Beep
    
    wbCompile.Activate
    wbCompile.Worksheets("Dashboard").Select
    wbCompile.Save
    
    Application.Calculation = xlCalculationAutomatic 'reset calcs

End Sub

'count unique values inrange `rng`
Function Unique(rng As Range) As Long 'prefer Long over Integer
    Dim arr, r As Long, c As Long, List As Object, v
    Set List = CreateObject("Scripting.dictionary")
    arr = rng.Value 'read to array (faster)
    For r = 1 To UBound(arr, 1)      'loop over rows and colummns
        For c = 1 To UBound(arr, 2)
            v = arr(r, c)
            If Len(v) > 0 Then
                If Not List.Exists(v) Then List.Add v, Nothing
            End If
        Next c
    Next r
    Unique = List.Count
End Function