[VBA]汇总多个工作簿的指定工作表到同一个工作簿的指定工作表中

sub 汇总多个工作簿()

Application.ScreenUpdating = False

Dim wb As Workbook, f As String, l As String, n As String, m As String, j As Integer

f = ThisWorkbook.Path & "\"

l = f & "*.xls"

m = Dir(l)

Do While m <> ""

If m <> ThisWorkbook.Name Then

n = f & m

Workbooks.Open (n)

With ThisWorkbook.activesheet

.Range("b4:at34").ClearContents

For i = 4 To .Range("a1").CurrentRegion.Rows.Count

For j = 2 To .Range("a1").CurrentRegion.Columns.Count - 2 Step 3

For Each wb In Workbooks

If wb.Name <> ThisWorkbook.Name Then

aa = Left(wb.Name, InStrRev(wb.Name, ".") - 1)

If .Cells(2, j).Value = aa Then

.Cells(i, j) = Application.VLookup(.Cells(i, 1), wb.Worksheets(1).Range("a:b"), 2, 0)

.Cells(i, j + 1) = Application.VLookup(.Cells(i, 1), wb.Worksheets(1).Range("a:c"), 3, 0)

If VBA.IsNumeric(ThisWorkbook.activesheet.Cells(i, j + 1)) = False Then

ThisWorkbook.activesheet.Cells(i, j + 2) = 0

ElseIf ThisWorkbook.activesheet.Cells(i, j + 1) = 0 Then

ThisWorkbook.activesheet.Cells(i, j + 2) = 0

Else

ThisWorkbook.activesheet.Cells(i, j + 2) = ThisWorkbook.activesheet.Cells(i, j) / ThisWorkbook.activesheet.Cells(i, j + 1)

End If

End If

End If

Next

Next

Next

End With

End If

m = Dir

Loop

For Each wb In Workbooks

If wb.Name <> ThisWorkbook.Name Then

wb.Close False

End If

Next

Application.ScreenUpdating = True

End Sub

效果图：

不足：

调用excel本身的函数vlookup，数据量大的话，会导致运行速度慢，表格卡住的问题，后期优化，应用数组解决。