VBA - 从文件夹中的所有文件复制特定单元格并将每个文件复制的列粘贴为主表中的单独列
我有很多文件只有一张纸（有时这些纸的名称不同，但它们包含相似的数据排列）。 我需要从文件夹中的每个工作簿中复制一个特定的列，并且这些复制的列中的每一个都需要作为单独的列制表到主表中。 另外我需要文件名作为从中复制值的每一列的标题
xls文件是文件类型
【问题讨论】：
标签： excel vba copy autofilter
尝试这个。
Sub FromAllFilesIntoColumns()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceCcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim Cnum As Long, CalcMode As Long
'Fill in the patholder where the files are
MyPath = "C:UsersRon est"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Cnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all rows then skip this file
If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceCcount = sourceRange.Columns.Count
If Cnum + SourceCcount >= BaseWks.Columns.Count Then
MsgBox "Sorry there are not enough columns in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in the first row
With sourceRange
BaseWks.cells(1, Cnum). _
Resize(, .Columns.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.cells(2, Cnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Cnum = Cnum + SourceCcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
【讨论】：
Sub ImportColumns()
' Define constants.
Const SOURCE_FOLDER_PATH As String = "C:Test"
Const SOURCE_WORKSHEET_ID As Variant = 1 ' the first (you say: 'and only')
Const SOURCE_FIRST_CELL_ADDRESS As String = "A2"
Const SOURCE_FILE_PATTERN As String = "*.xls" ' only `.xls`
Const DESTINATION_WORKSHEET_NAME As String = "Master"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
' Write the source file paths to a collection.
Dim pSep As String: pSep = Application.PathSeparator
Dim sPath As String: sPath = SOURCE_FOLDER_PATH
If Right(sPath, 1) <> pSep Then sPath = sPath & pSep
Dim sFolderName As String: sFolderName = Dir(sPath, vbDirectory)
If Len(sFolderName) = 0 Then
MsgBox "The path '" & sPath & "' doesn't exist.", vbExclamation
Exit Sub
End If
Dim sDirPattern As String: sDirPattern = sPath & SOURCE_FILE_PATTERN
Dim sFileName As String: sFileName = Dir(sDirPattern)
If Len(sFileName) = 0 Then
MsgBox "No '" & SOURCE_FILE_PATTERN & "' files found in '" _
& sPath & "'.", vbExclamation
Exit Sub
End If
Dim coll As Collection: Set coll = New Collection
Do While Len(sFileName) > 0
coll.Add sPath & sFileName
sFileName = Dir
Loop
Application.ScreenUpdating = False
' Write data to a jagged array:
' - the 1st column will hold the headers (file name without extension)
' - the 2nd column will hold the source number of rows
' for the final inner loop i.e. 'For dr = 1 To dJag(c, 2)';
' this row number is used anyway, to determine the number
' of destination rows.
' - the 3rd column will hold an array with the source range values
Dim dcCount As Long: dcCount = coll.Count
Dim dJag As Variant: ReDim dJag(1 To dcCount, 1 To 3)
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1) ' if one cell
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Dim srCount As Long
Dim swbName As String
Dim drCount As Long
Dim Item As Variant
Dim c As Long
For Each Item In coll
c = c + 1
Set swb = Workbooks.Open(Item, True, True)
swbName = swb.Name
' Write file name without extension.
dJag(c, 1) = Left(swbName, InStrRev(swbName, ".") - 1)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Set sfCell = sws.Range(SOURCE_FIRST_CELL_ADDRESS)
Set slCell = sfCell.Resize(sws.Rows.Count - sfCell.Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not slCell Is Nothing Then
Set srg = sws.Range(sfCell, slCell)
srCount = srg.Rows.Count
If srCount > drCount Then drCount = srCount ' determine max row
' Write number of rows.
dJag(c, 2) = srCount
' Write data.
If srCount = 1 Then ' one cell in column
OneCell(1, 1) = srg.Value
dJag(c, 3) = OneCell
Else ' multiple cells in column
dJag(c, 3) = srg.Value
End If
'Else ' no data in column; do nothing
End If
swb.Close SaveChanges:=False ' just reading
Next Item
Set coll = Nothing ' data is in 'dJag'
drCount = drCount + 1 ' + 1 for headers
' Write the data from the jagged array to the destination array.
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim dr As Long
For c = 1 To dcCount
' Write header.
dData(1, c) = dJag(c, 1)
' Write data.
If Not IsEmpty(dJag(c, 2)) Then
For dr = 1 To dJag(c, 2)
dData(dr + 1, c) = dJag(c, 3)(dr, 1) ' + 1 due to headers
Next dr
'Else ' no data in column; do nothing
End If
Next c
Erase dJag ' data is in 'dData'
' Write the data from the destination array to the destination range.
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
【讨论】：