VBA代码可使用文件名将一个工作表中的多个单元格粘贴到另一个工作表中

Question

我刚开始使用VBA代码。因此对这样的编码不熟悉。只是复制了一些代码片段。但是，没有得到想要的输出。

我要做的是遍历文件夹中的excel文件，并将所需的数据从工作表粘贴到主工作表中。

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 ws2 As Worksheet
Dim ws3 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:\Users\check"
    .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 = "*.xls*"

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

Set y = Workbooks.Open("C:\Users\Super\Desktop\Master")
Set ws2 = y.Sheets("Conso P-L")
Set ws3 = y.Sheets("Conso Expenses")

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

    With wb.Sheets("Profit-Loss")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
    End With
    Application.CutCopyMode = False

    With wb.Sheets("Expenses")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws3.Range("A" & Rows.Count).End(xlUp)(2)
    End With
    Application.CutCopyMode = False
    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

但是，问题是我需要在主工作表中添加一列以获得源数据的文件名（不包括.xls或.xlsx），我无法弄清楚在哪里调整代码！

在下面为我需要的所需输出添加了屏幕截图。在主工作簿的两个工作表的A列中都需要文件名。

感谢有人可以帮忙。

Answer 1

在要复制的代码中，将A替换为B粘贴范围。

With wb.Sheets("Profit-Loss")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws2.Range("B" & Rows.Count).End(xlUp)(2)
End With

现在，您的数据将从B列开始粘贴。

要获取要复制的文件的名称，可以使用myFile.name。您希望将其粘贴到刚刚复制数据的同一行上，因此，请利用您计算出的内容来确定要复制的内容（lRow）以及A列中的最后一个空行。

Dim lRowA as Long
Dim PasteRows as Long
lRowA = ws2.Range("A" & Rows.Count).End(xlUp)
PasteRows = lRowA + lRow -1 ' the -1 is to compensate for the fact that your copy area starts on row 2.

ws2.Range(ws2.Cells(lRowA,1),ws2.Cells(PasteRows,1)).value = myFile.name

您可以使用上面的代码用文件名填充A列。将其直接放在结尾（两次）后，并更改适当的ws名称（ws2 / ws3）以匹配with语句中的代码。