VBA：将文件夹中所有工作簿的范围复制到另一个工作簿中的工作表，其中包含每个 wb 的工作簿名称

Question

我想遍历一个文件夹中的所有工作簿，从工作表“导入 fil”复制数据，A 列：CZ 从第 5 行开始一直到 A 列中的最后一个活动行。然后将数据作为值粘贴到另一个工作簿中“ TOT_Importfiler.xlsm”，工作表“Blad1”。 每个新工作簿中的数据应粘贴到 TOT 文件的下一个空行中。 此外，我想将每个工作簿的工作簿名称添加到 TOT 文件中 DA 列中该工作簿的所有行，以便我可以跟踪数据来自哪个工作簿。 （最好是我想要 A 列中的工作簿名称和从 TOT 文件中 B 列开始的工作簿中复制的数据，但在最后添加它也可以）。

我使用了另一篇文章中的代码，但我不知道如何添加工作簿名称。 它还会粘贴公式而不是值，当存在指向我无权访问的另一个工作簿的链接时会导致错误。

谁能帮我吗？

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim lRow2 As Long
Dim ws2 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "C:\Importfiler test"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("C:\Importfiler test\TOT_Importfiler.xlsm")
Set ws2 = y.Sheets("Blad1")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
    With wb.Sheets("Import fil")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A5:CZ" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
        
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 1

修改以下代码行

.Range("A5:CZ" & lRow).Copy
 ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues

在上一行之后添加文件名使用以下代码

ws2.Range("A" & Rows.Count).End(xlUp)(2).offset(0,104) = myFile

Answer 2

从已关闭的工作簿中导入数据

Sub ImportData()

    ' Define constants.
    
    Const PROC_TITLE As String = "Import Data"
    Const SRC_INITIAL_FOLDER_PATH As String = "C:\Importfiler test\"
    Const SRC_FILE_PATTERN As String = "*.xlsx"
    Const SRC_WORKSHEET_NAME As String = "Import Fil"
    Const SRC_FIRST_ROW As String = "A5:CZ5"
    Const DST_FOLDER_PATH As String = "C:\Importfiler test\"
    Const DST_WORKBOOK_NAME As String = "TOT_Importfiler.xlsm"
    Const DST_WORKSHEET_NAME As String = "Blad1"
    Const DST_FIRST_COLUMN As String = "A"

    Dim pSep As String: pSep = Application.PathSeparator
    
    ' Check if the Destination folder and file exist.

    ' Correct.
    Dim dPath As String: dPath = DST_FOLDER_PATH
    If Right(dPath, 1) <> pSep Then dPath = dPath & pSep
    ' Folder
    If Len(Dir(dPath, vbDirectory)) = 0 Then
        MsgBox "The Destination folder '" & dPath & "' doesn't exist.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    ' File
    Dim dFilePath As String: dFilePath = dPath & DST_WORKBOOK_NAME
    If Len(Dir(dFilePath)) = 0 Then
        MsgBox "The Destination file '" & DST_WORKBOOK_NAME & "' was not " _
            & "found in '" & dPath & "'.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Select the Source folder.
    
    Dim sPath As String: sPath = SRC_INITIAL_FOLDER_PATH
    If Right(sPath, 1) <> pSep Then sPath = sPath & pSep

    Dim FolderDialogCanceled As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sPath
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> pSep Then sPath = sPath & pSep
        Else
            FolderDialogCanceled = True
        End If
    End With
            
    If FolderDialogCanceled Then
        MsgBox "No folder selected.", vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Check if there are any files in the Source folder.
    
    Dim sFileName As String: sFileName = Dir(sPath & SRC_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No Source files found in '" & sPath & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Reference the Destination objects.
    
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = dwb.Worksheets(DST_WORKSHEET_NAME)
    On Error GoTo 0
    If dws Is Nothing Then
        MsgBox "The worksheet '" & DST_WORKSHEET_NAME & "' was not found in " _
            & "the workbook '" & DST_WORKBOOK_NAME & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
        
    Dim dfCell As Range
    With dws.UsedRange
        Set dfCell = dws.Cells(.Row + .Rows.Count, DST_FIRST_COLUMN)
    End With

    Dim cCount As Long: cCount = dws.Range(SRC_FIRST_ROW).Columns.Count

    ' Copy the data.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, slCell As Range
    Dim rCount As Long

    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sPath & sFileName)
        On Error Resume Next
            Set sws = swb.Worksheets(SRC_WORKSHEET_NAME)
        On Error GoTo 0
        If Not sws Is Nothing Then ' worksheet exists
            If sws.FilterMode Then sws.ShowAllData
            With sws.Range(SRC_FIRST_ROW)
                ' Reference the Source range.
                Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
                    .Find("*", , xlFormulas, , , xlPrevious)
                If Not slCell Is Nothing Then ' data in worksheet found
                    rCount = slCell.Row - .Row + 1
                    Set srg = .Resize(rCount)
                    ' Copy values.
                    With dfCell.Resize(rCount)
                        .Value = sFileName
                        .Offset(, 1).Resize(, cCount).Value = srg.Value
                    End With
                    Set dfCell = dfCell.Offset(rCount)
                'Else ' no data in worksheet found; do nothing
                End If
            End With
            Set sws = Nothing ' reset for the next iteration
        'Else ' worksheet doesn't exist; do nothing
        End If
        swb.Close SaveChanges:=False ' it was just read from
        sFileName = Dir
    Loop

    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Data imported!", vbInformation, PROC_TITLE

End Sub