baigangliao 发表于 2014-1-13 10:15 
谢谢!赵老师:我想把1-12月按姓名汇总怎么办呢?sheet1改1月其它以此类推 - Sub Macro1()
- Dim arr, brr(1 To 60000, 1 To 8), crr(), i&, j&, l&, m&, n&, sh As Worksheet, d As Object
- Set d = CreateObject("scripting.dictionary")
- For Each sh In Sheets
- If sh.Name <> "汇总" Then
- arr = sh.[a1].CurrentRegion
- For l = 1 To 16 Step 8
- For i = 4 To UBound(arr)
- r = d(arr(i, l) & arr(i, l + 1))
- If r = "" Then
- m = m + 1
- d(arr(i, l) & arr(i, l + 1)) = m
- n = 0
- For j = l To l + 6
- n = n + 1
- If n = 5 Then
- brr(m, n) = arr(i, 4) * 20
- Else
- brr(m, n) = arr(i, j)
- End If
- Next
- Else
- n = 2
- For j = l + 2 To l + 6
- n = n + 1
- If n = 5 Then
- brr(r, n) = brr(r, n) + arr(i, 4) * 20
- Else
- brr(r, n) = brr(r, n) + arr(i, j)
- End If
- Next
- End If
- Next
- Next
- End If
- Next
- n = WorksheetFunction.RoundUp(m / 2, 0)
- For i = 1 To n
- brr(i, 8) = brr(i, 3) + brr(i, 4) + brr(i, 5) - brr(i, 6) + brr(i, 7)
- Next
- ReDim crr(n + 1 To m, 1 To 8)
- For i = n + 1 To m
- For j = 1 To 7
- crr(i, j) = brr(i, j)
- Next
- crr(i, 8) = crr(i, 3) + crr(i, 4) + crr(i, 5) - crr(i, 6) + crr(i, 7)
- Next
- With Sheets("汇总")
- .UsedRange.Offset(3).ClearContents
- .[a4].Resize(n, 8) = brr
- .[i4].Resize(n, 8) = crr
- .Activate
- End With
- End Sub
复制代码 |