使用VBA将列标题设为文件名 [英] Making the column header the file name using VBA

问题描述

我真的是VBA的新手，所以这是我在网上找到并结合使用的一些代码.现在分为三部分(最后一部分对我的问题并不那么重要).第一部分编译"遍历一个文件夹中的所有文件，并调用第二部分"copydata"，它复制标题为"direction"或"instruction"的列下的数据，并将其粘贴到新的工作表"Summary"中.现在，代码将数据粘贴到下一个空列中.我该如何更新代码，以便每次将数据放入新列时，标题方向"或指令"都被替换为与数据相对应的文件名

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

推荐答案

未测试

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将列标题设为文件名的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！