我正在努力解决这个问题，但它超出了我的知识范围。
我想通过在代码中添加"Header Name"来提取更多列数据。但是我的代码只适用于单个标头。
我尝试添加一个像这样的数组
Const sHeader As String = Array("Category", "Names")等
但是我得到一个错误。
我想让Add File Names在文件夹中循环遍历它们，并跳过其余的文件。
如Const sFileName As String = Array("File1", "File2")等。
我想通过它的Header分隔符复制和粘贴每个列。
如果有人能帮我，我会很感激。
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
在我看来，"循环非常慢，我会尽量避免使用它们。相反，使用已定义的"For"或"For each";循环。
关键是使用数组，并且在每个"For"循环请求存储在这些数组中的信息。
这是一个想法(它还没有完成)使用"For"循环，一个在另一个里面。第一个是打开文件，第二个是打开工作表，第三个是检查标题。请检查变量"arrFiles(X)"。和"arrHeaders (Y),
Dim wbkSheet As Worksheet
Dim Wbk As Workbook
Dim X As Double, Y As Double
Dim sHeaderRow As Byte: sHeaderRow = 1
Dim shRg As Range, sfCell As Range
'Here we set the values for the Files names and Table Headers names. They'll be Arrays
Dim arrFiles As Variant: arrFiles = Array("File_1.xlsx", "Files_2.xlsx")
Dim arrHeader As Variant: arrHeader = Array("Category", "Names")
'Loop to check every file that is in the Array
For X = LBound(arrFiles, 1) To UBound(arrFiles, 1)
'Loop to open every file of the list
'Example:
Set Wbk = Workbooks.Open(sFolderPath & arrFiles(X))
'...
For Each wbkSheet In Wbk.Worksheets
'Loop to open every sheet of the opened file.
For Y = LBound(arrHeader, 1) To UBound(arrHeader, 1)
'Loop to check every column of the sheet
'Example:
Set shRg = wbkSheet.Rows(sHeaderRow)
Set sfCell = shRg.Find(arrHeader(Y), shRg.Cells(shRg.Cells.Count), xlFormulas, xlWhole)
'...
Next Y
Next wbkSheet
Next X
使用这段代码，您可以添加任意数量的文件和头文件。
现在，在我看来，最好的解决方案是使用ADO Excel，它是更快的方式(它使用SQL查询)，你不需要打开文件。循环将会短得多，因为你只需要建立SQL查询。
使用Const初始化数组的一个建议是这样声明标题:
Const ALL_HEADERS As String = "Category,Names"
Dim sHeader() As String
sHeader = Split(ALL_HEADERS, ",")
数组已设置。