Sub 合并工作簿数据()
Dim arr
Dim i As Integer, j As Integer, x As Integer
Dim f As String, m As String, n As String
ActiveSheet.Range("b4:y34").ClearContents
f = ThisWorkbook.Path & "\"
l = f & "*.xls"
m = Dir(l)
Do While m <> ""
If m <> ThisWorkbook.Name Then
n = f & m
Set wb = GetObject(n)
For i = 4 To ActiveSheet.Range("a65536").End(xlUp).Row '行
For j = 2 To ActiveSheet.Range("b3").End(xlToRight).Column - 2 Step 3 '列
aa = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
If ActiveSheet.Cells(2, j).Value = aa Then
arr = wb.Worksheets(1).Range("a1").CurrentRegion
For x = 1 To UBound(arr)
If ActiveSheet.Cells(i, 1) = arr(x, 1) Then
ActiveSheet.Cells(i, j) = arr(x, 2)
ActiveSheet.Cells(i, j + 1) = arr(x, 3)
If VBA.IsNumeric(ActiveSheet.Cells(i, j + 1)) = False Then
ActiveSheet.Cells(i, j + 2) = 0
ElseIf ActiveSheet.Cells(i, j + 1) = 0 Then
ActiveSheet.Cells(i, j + 2) = 0
Else
ActiveSheet.Cells(i, j + 2) = ActiveSheet.Cells(i, j) / ActiveSheet.Cells(i, j + 1)
End If
End If
Next
End If
Next
Next

End If
m = Dir
Loop
Set wb = Nothing
End Sub