|
代码如下:
- Sub 汇总()
- Dim arr, i As Long, j As Long, mFile As String, wb As Workbook, mStr As String
- Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
- mFile = ThisWorkbook.Path & "\\基础信息.xls"
- Set wb = GetObject(mFile)
- arr = wb.Worksheets(1).UsedRange.Value
- wb.Close False
- For i = 5 To UBound(arr)
- If Len(arr(i, 4)) Then
- For j = 5 To UBound(arr, 2)
- mStr = arr(i, 4) & arr(4, j)
- If Not d.Exists(mStr) Then d(mStr) = arr(i, j)
- Next
- End If
- Next
- mFile = ThisWorkbook.Path & "\\加改.xls"
- Set wb = GetObject(mFile)
- arr = wb.Worksheets(1).UsedRange.Value
- wb.Close False
- For i = 5 To UBound(arr)
- If Len(arr(i, 2)) Then
- For j = 5 To UBound(arr, 2)
- mStr = arr(i, 2) & arr(4, j)
- If Not d.Exists(mStr) Then d(mStr) = arr(i, j)
- Next
- End If
- Next
- With ThisWorkbook.Worksheets("汇总数据")
- .Activate
- .Range("E5:T65536").ClearContents
- arr = .UsedRange.Value
- For i = 5 To UBound(arr)
- If Len(arr(i, 4)) Then
- For j = 5 To UBound(arr, 2)
- mStr = arr(i, 4) & arr(4, j)
- If d.Exists(mStr) Then arr(i, j) = d(mStr)
- Next
- End If
- Next
- .UsedRange.Value = arr
- End With
- Set d = Nothing: Set wb = Nothing
- End Sub
复制代码
|
评分
-
1
查看全部评分
-
|