Question

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

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

使用VBA

1 个答案: