如何根据原始表的4列关键字班级姓名大类小类生成目标表和统计表20180621

yzyyyyyyy · 发表于 2018-6-21 15:50

原始表中：关键列班级，姓名，大类，小类，不固定

如何根据原始表的4列关键字班级姓名大类小类生成目标表和统计表20180621.rar (19.94 KB, 下载次数: 5)
目标表：根据大类，小类生成各班级名单
统计表：生成各班级各大类小类人数。

chxw68 · 发表于 2018-6-22 18:18

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("原始")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:h" & r)
End With
ReDim crr(1 To 14)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 1)).exists(arr(i, 7)) Then
Set d(arr(i, 1))(arr(i, 7)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 1))(arr(i, 7)).exists(arr(i, 8)) Then
m = 1
ReDim brr(1 To m)
Else
brr = d(arr(i, 1))(arr(i, 7))(arr(i, 8))
m = UBound(brr) + 1
ReDim Preserve brr(1 To m)
End If
brr(m) = arr(i, 3)
d(arr(i, 1))(arr(i, 7))(arr(i, 8)) = brr
Next
With Worksheets("目标表")
.Cells.Clear
.Range("a3").Resize(1, 14) = [{"班级","合计","报名","","","","","","未报名","","","","",""}]
.Range("a4").Resize(1, 14) = [{"","","小计","休学","正常","转出","转学","复学","小计","休学","正常","转出","转学","复学"}]
For j = 2 To 14
If .Cells(3, j) = "" Then
.Cells(3, j - 1).Resize(1, 2).Merge
End If
Next
.Range("a3").Resize(2, 1).Merge
.Range("b3").Resize(2, 1).Merge
m = 6
For Each aa In d.keys
n1 = -3
hj = 0
For Each bb In Array("报名", "未报名")
n1 = n1 + 6
If d(aa).exists(bb) Then
n2 = 0
For Each cc In Array("休学", "正常", "转出", "转学", "复学")
n2 = n2 + 1
If d(aa)(bb).exists(cc) Then
brr = d(aa)(bb)(cc)
.Cells(m, n1 + n2).Resize(UBound(brr), 1) = Application.Transpose(brr)
If hj < UBound(brr) Then
hj = UBound(brr)
End If
Else
gs1 = gs1 & "+" & "0"
End If
Next
End If
Next
For Each y In Array(1, 2, 3, 9)
With .Cells(m, y)
.Resize(hj, 1).Merge
End With
Next
With .Cells(m, 1)
.Value = aa
End With
m = m + hj
Next
r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ReDim crr(1 To 14)
ReDim drr(1 To 14)
For i = 6 To r
If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
hs = .Cells(i, 1).MergeArea.Rows.Count
gs0 = ""
hj0 = 0
For k = 3 To 9 Step 6
gs1 = ""
hj1 = 0
For j = 1 To 5
s = Application.CountA(.Cells(i, j + k).Resize(hs, 1))
gs1 = gs1 & "+" & s
hj1 = hj1 + s
crr(j + k) = crr(j + k) & "+" & s
drr(j + k) = drr(j + k) + s
Next
.Cells(i, k) = hj1 & "=" & Mid(gs1, 2)
gs0 = gs0 & "+" & hj1
hj0 = hj0 + hj1
Next
.Cells(i, 2) = hj0 & "=" & Mid(gs0, 2)
With .Cells(i, 1).Resize(hs, 14)
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlDouble, Weight:=xlMedium
End With
End If
Next
For k = 3 To 9 Step 6
For j = 1 To 5
crr(j + k) = drr(j + k) & "=" & Mid(crr(j + k), 2)
crr(k) = crr(k) & "+" & drr(j + k)
drr(k) = drr(k) + drr(j + k)
Next
crr(k) = drr(k) & "=" & Mid(crr(k), 2)
crr(2) = crr(2) & "+" & drr(k)
drr(2) = drr(2) + drr(k)
Next
crr(2) = drr(2) & "=" & Mid(crr(2), 2)
.Range("a5").Resize(1, 14) = crr
With .Cells(3, 1).Resize(3, 14)
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlDouble, Weight:=xlMedium
End With
For Each y In Array(2, 8, 14)
With .Cells(3, y).Resize(r - 2).Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
Next
With .UsedRange
With .Font
.Size = 10
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-6-22 18:18

详见附件。

yzyyyyyyy · 发表于 2018-6-22 21:05

本帖最后由 yzyyyyyyy 于 2018-6-25 17:13 编辑

chxw68 发表于 2018-6-22 18:18

感谢大师热心帮助，解决了一大难题。平时，大类和小类，其中的项目非固定，能否直接根据原始表关键列动态提取生成。改了一点，有些问题，人数不对

如何根据原始表4列生成目标表统计表.rar (29.48 KB, 下载次数: 2)

		自动登录	找回密码
密码			免费注册

[求助] 如何根据原始表的4列关键字班级姓名大类小类生成目标表和统计表20180621

评分

评分