M
第一步我们要把这个读入工作表名和读出工作表名的map读入宏。可以这么写。这里是选择了Parameters这个工作表里面"A1"按住Ctrl+A选中的区域，并通过Offset向下移一格，然后用resize减少一行；这样可以去掉读入的表标题。
Dim mapping As Variant
With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion
mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With
那么我们就把下面这个表储存到mapping这个变量里面啦
然后我们定义一个变量用来储存每个读出的数据总数，这里我们需要三组变量；因此这应该是一个有三个数字的数组。
Dim cntrows As Variant
ReDim cntrows(UBound(mapping, 1))
最后一步就是循环每个工作薄里面的每个工作表，如果这个工作表名能和Map里面的第一列任意一个匹配，那么它就会被输出到Map里面第二列对应的工作表内。
For Each st In wbResults.Worksheets
For i = 1 To UBound(mapping, 1)
If st.Name = mapping(i, 1) Then
rng = st.UsedRange.Value
ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
cntrows(i) = cntrows(i) + UBound(rng, 1)
End If
Next i
完整代码
Sub Copyfrom_all_excel_files_in_folder()
Dim FoldPath As String
Dim DialogBox As FileDialog
Dim FileOpen As String
Dim rng As Variant
On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
FoldPath = DialogBox.SelectedItems(1)
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'read the mapping to the macro
Dim mapping As Variant
With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion
mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With
Dim cntrows As Variant
ReDim cntrows(UBound(mapping, 1))
Dim i As Integer
' If the output sheet does not exist create it
For i = 1 To UBound(mapping, 2)
If WorksheetExists(mapping(i, 2)) = False Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = mapping(i, 2)
Next i
On Error GoTo 0
If FoldPath = "" Then Exit Sub
FileOpen = Dir(FoldPath & "\*.xls*")
Do While FileOpen <> ""
Set wbResults = Workbooks.Open(FoldPath & "\" & FileOpen, UpdateLinks:=0, ReadOnly:=True)
For Each st In wbResults.Worksheets
For i = 1 To UBound(mapping, 1)
If st.Name = mapping(i, 1) Then
rng = st.UsedRange.Value
ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
cntrows(i) = cntrows(i) + UBound(rng, 1)
End If
Next i
Next
wbResults.Close
FileOpen = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function WorksheetExists(ByVal shtName As String, Optional ByVal wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
Copy_to_excel - V2.zip