Making the column header the file name using VBA

2019-08-30 06:27发布

I'm really new to VBA so this is some code that I found online and combined. Right now there are 3 parts (the last part isn't that important to my question). The first part "compile" loops through all the files in a folder and calls the second part "copydata" which copies data under columns with the header "direction" or "instruction" and pastes it into a new sheet "Summary". Right now the code pastes the data into the next empty column. How can I update my code such that every time data is put into a new column, the headers "direction" or "instruction" are replaced with the datas corresponding file name

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

1条回答
Animai°情兽
2楼-- · 2019-08-30 07:05

Not tested

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

And then in your sub

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

And then

(...)
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
查看更多
登录 后发表回答