使用 VBA 使列标题成为文件名

Question

我真的是 VBA 新手，所以这是我在网上找到并组合起来的一些代码。现在有 3 个部分（最后一部分对我的问题并不重要）。第一部分“编译”循环遍历文件夹中的所有文件，并调用第二部分“copydata”，它复制标题为“direction”或“instruction”的列下的数据并将其粘贴到新的工作表“Summary”中。现在，代码将数据粘贴到下一个空列中。如何更新我的代码，以便每次将数据放入新列时，将标题“方向”或“指令”替换为数据对应的文件名

Sub Compile()
Dim xsource As Workbook
Dim NewWS As Worksheet
Dim original As Worksheet
Dim FileNeeded As String
Dim xPath As String

'clear contents from previous sheet
Sheets("summary").Cells.ClearContents
' Initialize some variables and get the folder path that has the files
Set NewWS = ThisWorkbook.Sheets("summary")
xPath = GetPath
' Make sure a folder was picked.
If Not xPath = vbNullString Then

' Get all the files from the folder
FileNeeded = Dir$(xPath & "*.xlsm", vbNormal)
Do While Not FileNeeded = vbNullString

' Open the file and get the source sheet
    Set xsource = Workbooks.Open(xPath & FileNeeded)
    Set original = xsource.Sheets("sum")

    Call CopyData(original, NewWS)

    'Close the workbook and move to the next file.
    xsource.Close False
    FileNeeded = Dir$()

    Loop
End If
End Sub

Sub CopyData(original As Worksheet, NewWS As Worksheet)
Dim title As Range
Dim LastCol As Long

With original.Rows(1)
Set title = .Find("direction")
If title Is Nothing Then Set title = .Find("instruction")
End With

'Get last used column, and add 1 (for next one)
LastCol = NewWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1

If Not title Is Nothing Then
    title.EntireColumn.Copy
    NewWS.Cells(1, LastCol).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = xlCopy
    NewWS.Columns(LastCol).RemoveDuplicates Columns:=1, Header:=xlNo
  Else
    MsgBox "Error"
End If
End Sub

Function GetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .ButtonName = "Select a folder"
    .title = "Folder Picker"
    .AllowMultiSelect = False
    If .Show Then GetPath = .SelectedItems(1) & "\"
    End With
End Function

Answer 1

未测试

Set xsource = Workbooks.Open(xPath & FileNeeded)
Set original = xsource.Sheets("sum")
FileName= xsource.Name 'add this line

Call CopyData(original, NewWS, FileName) 'add the file name into the parameters of your sub

然后在你的潜艇中

 Sub CopyData(original As Worksheet, NewWS As Worksheet, TheFileName as String)

然后

(...)
NewWS.Columns(LastCol).RemoveDuplicates Columns:=1, Header:=xlNo 'this is your code, just to indicate where to add the next line
NewWS.Cells(1, LastCol)=TheFileName 'add this line