|
用VBA数组按开始结束日期 实现分类统计汇总
本帖最后由 chart888 于 2017-6-1 11:05 编辑
- Private Sub CommandButton1_Click()
- On Error Resume Next
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Dim arr
- Dim arr1(1 To 10000, 1 To 20)
- Dim arr2(1 To 1, 1 To 20)
- Dim D1, D2, sInt
- Dim A1, A2, k, k1, x, m, n, i As Integer
- Set D1 = CreateObject("Scripting.Dictionary")
- Set D2 = CreateObject("Scripting.Dictionary")
- With Sheets("Sheet1")
- .Range("G1").CurrentRegion.Clear
- sInt = Application.InputBox(Prompt:="输入开始日期", Type:=1)
- If Len(Trim(sInt)) > 7 Then
- A1 = sInt
- Else
- MsgBox Prompt:="您没有输入有效的日期" & Chr(10) _
- & "正确的月份格式为:(例:20150601)", Buttons:=vbOKOnly + vbInformation, _
- Title:="错误提示"
- Exit Sub
- End If
- sInt = Application.InputBox(Prompt:="输入结束日期", Type:=1)
- If Len(Trim(sInt)) > 7 Then
- A2 = sInt
- Else
- MsgBox Prompt:="您没有输入有效的日期" & Chr(10) _
- & "正确的月份格式为:(例:20150601)", Buttons:=vbOKOnly + vbInformation, _
- Title:="错误提示"
- Exit Sub
- End If
- k1 = 3
- arr = .Range("A2:D" & .Range("A65536").End(xlUp).Row)
- For x = 1 To UBound(arr)
- If arr(x, 1) >= A1 And arr(x, 1) <= A2 Then
- If D1.Exists(arr(x, 3)) Then
- n = D1(arr(x, 3))
- If D2.Exists(arr(x, 2)) Then
- m = D2(arr(x, 2))
- arr1(m, n) = arr1(m, n) + arr(x, 4)
- GoTo AA
- Else
- k = k + 1
- D2(arr(x, 2)) = k
- arr1(k, 1) = arr(x, 2)
- arr1(k, n) = arr(x, 4)
- GoTo AA
- End If
-
- Else
- k1 = k1 + 1
- D1(arr(x, 3)) = k1
- arr2(1, k1) = arr(x, 3)
- End If
- If D2.Exists(arr(x, 2)) Then
- m = D2(arr(x, 2))
- arr1(m, n) = arr1(m, n) + arr(x, 4)
- Else
- k = k + 1
- D2(arr(x, 2)) = k
- arr1(k, 1) = arr(x, 2)
- arr1(k, k1 - 1) = arr(x, 4)
- End If
- End If
- AA:
- Next
- arr2(1, 1) = "开始—结束"
- arr2(1, 2) = "姓名"
- arr2(1, 3) = "销售额合计"
- .Range("H2").Resize(k, D1.Count + 2) = arr1
- .Range("G1").Resize(1, D1.Count + 3) = arr2
- .Range("G2") = A1
- .Range("G3") = A2
- .Cells(D2.Count + 2, 8) = "合计"
- For i = 2 To D2.Count + 1
- .Cells(i, 9) = WorksheetFunction.Sum(.Range(Cells(i, 10).Address, Cells(i, D1.Count + 9).Address))
- Next
- .Cells(D2.Count + 2, 9) = WorksheetFunction.Sum(.Range(Cells(2, 9).Address, Cells(D2.Count + 1, 9).Address))
- With .Range("G1").CurrentRegion.Borders
- .LineStyle = xlContinuous
- .Weight = xlThin
- End With
- With .Range("G1").Resize(D2.Count + 2, D1.Count + 3)
- .EntireColumn.AutoFit
- .VerticalAlignment = xlCenter
- .HorizontalAlignment = xlCenter
- .Font.Name = "微软雅黑"
- .Font.Size = 11
- End With
- With .Range("G1").Resize(1, D1.Count + 3)
- .Font.FontStyle = "Bold"
- .Interior.ColorIndex = 34
- End With
- End With
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
复制代码
|
|