Создание заголовка столбца для имени файла с использованием VBA

Question

Я действительно новичок в VBA, так что это некоторый код, который я нашел в сети и в сочетании.Сейчас есть 3 части (последняя часть не так важна для моего вопроса).Первая часть «compile» проходит по всем файлам в папке и вызывает вторую часть «copydata», которая копирует данные под столбцами с заголовком «direction» или «инструкция» и вставляет их в новый лист «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