Dim d As Object '聲明變量
Dim ss$, n% '聲明變量
Range("A2:H" & [a65536].End(3).Row).Delete Shift:=xlUp '刪除A2至A列最後壹個非空單元格，到h列的區域，下方單元格上移
m = Sheet1.[d65536].End(xlUp).Row '獲取Sheet1d列最後壹個非空單元格行號
arr = Sheet1.Range("d1:h" & m) '將Sheet1d到h列數據讀入數組arr
Set d = CreateObject("scripting.dictionary") '創建字典
ReDim brr(1 To UBound(arr), 1 To 4) '創建二維數組brr
For i = 2 To UBound(arr) '這個循環的作用是將arr首列相同的數據合並後放入brr
ss = arr(i, 1)
If Not d.Exists(ss) Then
n = n + 1
d.Add ss, n
brr(n, 1) = arr(i, 1): brr(n, 2) = 1: brr(n, 3) = arr(i, 4): brr(n, 4) = arr(i, 5)
Else
brr(d(ss), 2) = brr(d(ss), 2) + 1
brr(d(ss), 3) = brr(d(ss), 3) & "|" & arr(i, 4)
brr(d(ss), 4) = brr(d(ss), 4) & "|" & arr(i, 5)
End If
Next
bt = [{"序號","","","數量","碼段","無碼段","碼段不清","戶數"}] '初始化數組bt
Columns("B:C").NumberFormatLocal = "@" '設置bc列為文本格式
d.RemoveAll '清除字典
ReDim crr(1 To (m - 1) + n * 3, 1 To 8) '創建二維數組crr
hs = 0
For i = 1 To n '這個循環為brr裏的每行數據制壹個表
For j = 1 To 8 '這個循環初始化表頭
crr(1 + hs, j) = bt(j)
Next
crr(1 + hs, 2) = brr(i, 1) '原表D列放到表頭第2列
p1 = Split(brr(i, 3), "|") '拆分
p2 = Split(brr(i, 4), "|") '拆分
For j = 1 To brr(i, 2) '這個循環將brr合並的壹行數據，重新拆分成原來的行數存入crr
crr(j + 1 + hs, 1) = j '第壹列為序號
crr(j + 1 + hs, 2) = p1(j - 1) '第2列為原表G列
crr(j + 1 + hs, 3) = p2(j - 1) '第3列為原表H列
ss = Right(crr(j + 1 + hs, 3), 6) '取原表H列數據右邊6位，沒有“*”且不重復的在第8列進行計數
If InStr(ss, "*") = 0 Then
If Not d.Exists(ss) Then
d.Add ss, ""
crr(j + 1 + hs, 8) = 1
crr(brr(i, 2) + 2 + hs, 8) = crr(brr(i, 2) + 2 + hs, 8) + 1
End If
End If
If InStr(crr(j + 1 + hs, 2) & crr(j + 1 + hs, 3), "*") = 0 Then '原表G、H列數據，沒有“*”在第5列進行計數，全是“*”在第6列進行計數，其余在第7列進行計數
crr(j + 1 + hs, 5) = 1
crr(brr(i, 2) + 2 + hs, 5) = crr(brr(i, 2) + 2 + hs, 5) + 1
Else
If Len(Replace(crr(j + 1 + hs, 2) & crr(j + 1 + hs, 3), "*", "")) = 0 Then
crr(j + 1 + hs, 6) = 1
crr(brr(i, 2) + 2 + hs, 6) = crr(brr(i, 2) + 2 + hs, 6) + 1
Else
crr(j + 1 + hs, 7) = 1
crr(brr(i, 2) + 2 + hs, 7) = crr(brr(i, 2) + 2 + hs, 7) + 1
End If
End If
crr(j + 1 + hs, 4) = 1
crr(brr(i, 2) + 2 + hs, 4) = crr(brr(i, 2) + 2 + hs, 4) + 1
Next
crr(brr(i, 2) + 2 + hs, 1) = "合計"
crr(brr(i, 2) + 3 + hs, 1) = "備註：卷煙" & crr(brr(i, 2) + 2 + hs, 4) & "條，碼段" & crr(brr(i, 2) + 2 + hs, 5) * 1 & "條，無碼段" & crr(brr(i, 2) + 2 + hs, 6) * 1 & "條，碼段不清" & crr(brr(i, 2) + 2 + hs, 7) * 1 & "條，涉及戶數" & crr(brr(i, 2) + 2 + hs, 8) * 1 & "戶"
d.RemoveAll
Cells(1, "a").Offset(brr(i, 2) + 1 + hs, 0).Resize(1, 3).Merge '合並單元格，每表倒數第二行前三列
Cells(1, "a").End(3).Offset(brr(i, 2) + 2 + hs, 0).Resize(1, 8).Merge '合並單元格，每表最後壹行8列
Cells(1, "a").End(3).Resize(1, 2).Offset(hs, 1).Merge '合並單元格，表頭2，3列，另外本行與上壹行代碼End(3).多余，有沒有效果壹樣，但是加上後影響運算速度
hs = hs + brr(i, 2) + 3 '表格總行數
Next
Cells(1, "a").Resize(UBound(crr), 8) = crr '將crr數據寫入單元格
Range("a1:h" & [a65536].End(3).Row).Borders.LineStyle = 1 '設置邊框
End Sub