Question

我正在组合一个工具，该工具从多个Excel文件中收集数据并将值粘贴到摘要表（与包含vba的文件相同）中。摘要表是一个表，因此即使行数发生变化，我的透视表也会引用所有数据。

源文件的格式不同，因此无法为每个文件循环播放。

下面是仅一个源工作簿的摘录，但数据是从2个工作表中提取的。它分两个步骤执行：1-复制并粘贴到临时工作表（shtemp-工作表的名称）中，然后在所有数据都在一起时，将其复制并粘贴到工作表ShSummary上的摘要表中。

它可以工作，但是我完全意识到这不是最有效的方法。在我将其与其他工作簿一起添加之前，有人可以提出一种方法来整理一下它，使其不会崩溃的问题吗？

非常感谢！

Sub Import_Data_TempSh()

    Dim FilePth As String
    Dim SourceBook As Workbook
    Dim LastCell_Nbr As Integer
    Dim Tbl As ListObject

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With

'Open Follow Up file
    FilePth = "C:\Users\xxx\Desktop\xxx\xxx\Follow-up_File.xlsm"
    Set SourceBook = Application.Workbooks.Open(FilePth)

        If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
            ActiveSheet.ShowAllData
        End If


'Copy and paste data values into summary sheet
    With SourceBook.Sheets("Follow up") 'Current Data
        LastCell_Nbr = Workbooks("Follow-up_File.xlsm").Sheets("Follow up").Cells(Rows.Count, "C").End(xlUp).Row


        .Range("A5:A" & LastCell_Nbr).Copy
            ShTemp.Range("B5").PasteSpecial xlPasteValues 
        .Range("Q5:Q" & LastCell_Nbr).Copy
            ShTemp.Range("D5").PasteSpecial xlPasteValues  
        .Range("C5:C" & LastCell_Nbr).Copy
            ShTemp.Range("E5").PasteSpecial xlPasteValues 
        .Range("G5:G" & LastCell_Nbr).Copy
            ShTemp.Range("F5").PasteSpecial xlPasteValues  
        .Range("P5:P" & LastCell_Nbr).Copy
            ShTemp.Range("H5").PasteSpecial xlPasteValues  
        .Range("E5:E" & LastCell_Nbr).Copy
            ShTemp.Range("I5").PasteSpecial xlPasteValues  
        .Range("H5:H" & LastCell_Nbr).Copy
            ShTemp.Range("J5").PasteSpecial xlPasteValues  
        .Range("X5:X" & LastCell_Nbr).Copy
            ShTemp.Range("M5").PasteSpecial xlPasteValues  
    End With


    With SourceBook.Sheets("Archived") 'Archived Data
        LastCell_Nbr = Workbooks("Follow-up_File.xlsm").Sheets("Archived").Cells(Rows.Count, "A").End(xlUp).Row

        .Range("B2:B" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues '#
        .Range("O2:O" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "D").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'Added on (Date)
        .Range("A2:A" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'MSN
        .Range("D2:D" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "F").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'CA
        .Range("N2:N" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "H").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'Status
        .Range("Y2:Y" & LastCell_Nbr).Copy
            ShTemp.Cells(Rows.Count, "I").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'Origin
    End With

'Add data to the summary table
    Set Tbl = ShSummary.ListObjects("SummaryTbl")
            ThisWorkbook.Activate
            LastCell_Nbr = ShTemp.Cells(Rows.Count, "E").End(xlUp).Row
            ShTemp.Range("B5:M5" & LastCell_Nbr).Copy
                Tbl.DataBodyRange(1, 1).PasteSpecial xlPasteValues

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .CutCopyMode = False
End With

End Sub

VBA Excel表（listobject）-导入数据

0 个答案: