|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub 按钮1_Click()
- Set d = CreateObject("scripting.dictionary")
- Set dd = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- ActiveSheet.UsedRange.Offset(2).Clear
- arr = Sheets("1").UsedRange
- For j = 2 To UBound(arr)
- If Len(arr(j, 10)) > 0 Then
- dd(arr(j, 3) & "###" & arr(j, 10)) = dd(arr(j, 3) & "###" & arr(j, 10)) + 1
- str1 = arr(j, 3) & arr(j, 10) & arr(j, 4) & arr(j, 8)
- If Not d.exists(str1 & arr(j, 5)) Then
- d(str1) = d(str1) + 1
- d(str1 & arr(j, 5)) = j
- End If
- End If
- Next j
- For j = 0 To dd.Count - 1
- Cells(j + 3, 1).Resize(1, 2) = Split(dd.keys()(j), "###")
- Next j
- [a3].Resize(dd.Count, 2).Sort key1:=[a3], Order1:=xlAscending
- arr = ActiveSheet.UsedRange
- For j = 3 To UBound(arr)
- sm = 0
- str1 = arr(j, 1) & arr(j, 2)
- For i = 3 To 7
- If d.exists(str1 & "微信" & arr(2, i)) Then
- arr(j, i) = d(str1 & "微信" & arr(2, i))
- sm = sm + arr(j, i)
- End If
- arr(j, 13) = sm
- Next i
- sm = 0
- For i = 8 To 12
- If d.exists(str1 & "电话" & arr(2, i)) Then
- arr(j, i) = d(str1 & "电话" & arr(2, i))
- sm = sm + arr(j, i)
- End If
- arr(j, 14) = sm
- Next i
- Next j
- ActiveSheet.UsedRange = arr
- r = Cells(Rows.Count, 1).End(3).Row + 1
- Cells(r, 1) = "合计"
- For j = 3 To UBound(arr, 2)
- Cells(r, j) = WorksheetFunction.Sum(Cells(3, j).Resize(r - 3))
- Next j
- arr = ActiveSheet.UsedRange
- For i = UBound(arr) - 1 To 3 Step -1
- If arr(i, 1) = arr(i + 1, 1) Then
- Cells(i, 1).Resize(2).Merge
- For j = 3 To UBound(arr, 2)
- Cells(r, j) = Cells(r, j) + Cells(i, j)
- Next j
- Else
- r = i + 1
- Rows(r).Insert
- Cells(r, 1).Resize(1, 2).Merge
- Cells(r, 1) = "合计"
- For j = 3 To UBound(arr, 2)
- Cells(r, j) = Cells(r, j) + Cells(i, j)
- Next j
- End If
- Next i
- ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|