我正在努力解决这个问题，但它超出了我的知识。
我想通过在代码中添加"Header Name"来提取更多列数据。但我的代码只适用于单头。
我试着添加一个像这样的数组
Const sHeader As String = Array("Category", "Names")等等。
但我得到一个错误。
我想Add File Names循环通过他们在文件夹和跳过其余的文件。
比如这个Const sFileName As String = Array("File1", "File2")等等。

我想通过标题分隔符复制并粘贴每个列。

如果有人能帮我这个忙，我将不胜感激。

Sub ImportColumns()
    
    ' Source
    Const sFilePattern As String = "*.xlsx"
    Const sExceptionsList As String = "Sheet1" ' comma-separated, no spaces
    Const sHeader As String = "Category"
    Const sHeaderRow As Long = 1
    ' Destination
    Const dColumn As String = "A"
    
    ' Source
    
    Dim sfd As FileDialog
    Set sfd = Application.FileDialog(msoFileDialogFolderPicker)
    'sfd.InitialFileName = "C:\Test\"
    
    Dim sFolderPath As String
    
    If sfd.Show Then
        sFolderPath = sfd.SelectedItems(1) & Application.PathSeparator
    Else
        'MsgBox "You canceled.", vbExclamation
        Beep
        Exit Sub
    End If
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    
    If Len(sFileName) = 0 Then
        'MsgBox "No files found.", vbExclamation
        Beep
        Exit Sub
    End If
    
    Dim sExceptions() As String: sExceptions = Split(sExceptionsList, ",")
    
    ' Destination
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.ActiveSheet ' improve!
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
    
    ' Loop.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim shrg As Range
    Dim sData() As Variant
    Dim sfCell As Range
    Dim slCell As Range
    Dim srCount As Long
    Dim wsCount As Long
    
    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sFolderPath & sFileName)
        For Each sws In swb.Worksheets
            If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
                Set shrg = sws.Rows(sHeaderRow)
                Set sfCell = shrg.Find(sHeader, shrg.Cells(shrg.Cells.Count), _
                        xlFormulas, xlWhole)
                If Not sfCell Is Nothing Then
                    Set sfCell = sfCell.Offset(1)
                    Set slCell = sfCell _
                        .Resize(sws.Rows.Count - sHeaderRow) _
                        .Find("*", , xlFormulas, , , xlPrevious)
                    If Not slCell Is Nothing Then
                        srCount = slCell.Row - sHeaderRow
                        Set srg = sfCell.Resize(srCount)
                    End If
                End If
                If srCount > 0 Then
                    If srCount = 1 Then
                        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
                    Else
                        sData = srg.Value
                    End If
                    dfCell.Resize(srCount).Value = sData
                    Set dfCell = dfCell.Offset(srCount)
                    wsCount = wsCount + 1
                    srCount = 0
                End If
            End If
        Next sws
        swb.Close SaveChanges:=False
        sFileName = Dir
    Loop
                
    ' Save the destination workbook.
    'dwb.Save
                
    Application.ScreenUpdating = True
    
    MsgBox wsCount & " '" & sHeader & "' columns copied.", vbInformation
                
End Sub

字符串