请大佬帮忙根据总表生成分析表

fnjpn · 发表于 2024-5-7 15:02

请大佬帮忙根据总表自动生成分析表

chxw68 · 发表于 2024-5-7 16:10

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("总表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For j = 3 To UBound(arr, 2) Step 7
ReDim brr(1 To UBound(arr) - 2, 1 To 10)
For i = 3 To UBound(arr)
brr(i - 2, 1) = arr(i, 1)
brr(i - 2, 2) = arr(i, 2)
brr(i - 2, 3) = arr(i, j + 6)
brr(i - 2, 5) = arr(i, j + 1)
brr(i - 2, 7) = arr(i, j + 3)
brr(i - 2, 9) = arr(i, j + 5)
Next
For Each q In Array(3, 5, 7, 9)
d1.RemoveAll
For i = 1 To UBound(brr)
If Len(brr(i, q)) <> 0 Then
d1(brr(i, q)) = d1(brr(i, q)) + 1
End If
Next
nn = 1
kk = d1.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d1(mm)
d1(mm) = nn
nn = nn + ss
Next
For i = 1 To UBound(brr)
If Len(brr(i, q)) <> 0 Then
brr(i, q + 1) = d1(brr(i, q))
End If
Next
Next
d(arr(1, j)) = brr
Next
With Worksheets("分析表")
.Cells.Clear
.Range("e:e,g:g,i:i").NumberFormatLocal = "0.00%"
r = 1
s = 0
For Each aa In d.keys
s = s + 1
brr = d(aa)
With .Cells(r, 1)
.Value = aa
.Resize(1, 10).Merge
End With
With .Cells(r + 1, 1).Resize(1, 10)
.Value = Array("初一年级", "统计人数", "平均分", "名次", "优秀率", "名次", "良好率", "名次", "合格率", "名次")
End With
With .Cells(r + 2, 1).Resize(UBound(brr), UBound(brr, 2))
.Value = brr
End With
With .Cells(r, 1).Resize(2 + UBound(brr), UBound(brr, 2))
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
If s Mod 2 = 0 Then
.Interior.Color = 15132391
End If
End With
r = r + 2 + UBound(brr)
Next
With .Range("a1:j" & r - 1)
With .Font
.Name = "微软雅黑"
.Size = 12
End With
End With
.Rows(1).Resize(r - 1).RowHeight = 18
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2024-5-7 16:12

练练手。。

fnjpn · 发表于 2024-5-7 16:23

chxw68 发表于 2024-5-7 16:12
练练手。。

非常感谢帮助，谢谢！

LIUZHU · 发表于 2024-5-11 17:00

弄起来还有点麻烦，是这个效果吗？

LIUZHU · 发表于 2024-5-11 17:01

JSA代码，共参考

function 数据整理(){
let arr=Sheets.Item("总表").Range("a1").CurrentRegion.Value2;
let bt1=arr[0],bt2=arr[1];
let cls=arr.slice(2,arr.length-1).map(x=>[x[0]]); //获取班级
let mbarr=[[null],["初一年级","统计人数","平均分","名次","优秀率","名次","良好率","名次","及格率","名次"]].concat(cls);
let obj=bt1.reduce((dic,y,j)=>{
if (j<=1) return dic;
if (mbarr[1].indexOf(bt2[j])==-1) return dic; //找不到要匹配的项目
let temp=dic[y]=dic[y] || JSON.parse(JSON.stringify(mbarr));
let n=temp[1].indexOf(bt2[j]);
temp[0][0]=y; //科目
arr.slice(2,arr.length-1).forEach(x=>{
let m=temp.findIndex(z=>z[0]==x[0]);
let tp=temp[m];
tp[1]=x[1],tp[n]=x[j];
let k=3+mbarr.length*(Object.keys(dic).length-1);
let l=mbarr.length*Object.keys(dic).length;
tp[n+1]=`=RANK.EQ(RC[-1],R${k}C[-1]:R${l}C[-1],)`;
});
return dic;
},{});
let res=Object.values(obj).flat();
Sheets.Item("分析表").Activate();
Cells.Delete();
Range("a1").Resize(res.length,res[1].length).FormulaR1C1=res;
//设置格式
Range("a1").CurrentRegion.Borders.LineStyle=xlContinuous;
Range("a1").CurrentRegion.HorizontalAlignment=xlHAlignCenter;
res[1].forEach((x,i)=>x.includes("率")?Cells.Item(1,i+1).EntireColumn.NumberFormatLocal="0.0%":null);
res.forEach((x,i)=>x[1]==null?Range(`a${i+1}`).Resize(1,10).Merge():null);
}

复制代码

LIUZHU · 发表于 2024-5-11 17:02

附件，WPS测试，谢谢

fnjpn · 发表于 2024-5-14 14:53

LIUZHU 发表于 2024-5-11 17:02
附件，WPS测试，谢谢

非常感谢帮助

fnjpn · 发表于 2024-5-14 14:56

Sub test()
Dim wsS As Worksheet, wsA As Worksheet
Dim sHr As Long, aHr As Long
Dim hRg As Range, sC As Range
Dim cR(), i%, pC%, fF As Boolean
Set wsS = ThisWorkbook.Worksheets("总表")
Set wsA = ThisWorkbook.Worksheets("分析表 (2)")
sHr = 2: aHr = 2
With wsA
      Set hRg = .Range(.Cells(aHr, 1), .Cells(aHr, .Columns.Count).End(xlToLeft))
   Set Rng = .Range(.Cells(2, 1), .Cells(2, .Columns.Count).End(xlToRight))
      dr = Rng.Value
End With
' 动态创建数组
ReDim cR(1 To hRg.Cells.Count)
pC = 0 ' 初始化前一列位置
For Each cell In hRg
      Set sC = wsS.Rows(sHr).Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
      If Not sC Is Nothing Then
         cR(i + 1) = sC.Column
         pC = sC.Column ' 更新前一找到的列位置
         fF = True ' 标记已找到
      ElseIf fF Then ' 使用前一列位置
         cR(i) = pC
      End If
      i = i + 1
      fF = False ' 重置找到标记
Next cell
Set sht = Sheets("总表")
ar = sht.Range("a1").CurrentRegion
m = UBound(ar) - 3
With Sheets("分析表")
.UsedRange.Clear
c = 1
k = 0
For j = 1 To UBound(ar, 2) ' 遍历第一行的所有列
      If InStr(1, ar(1, j), "总分", vbTextCompare) > 0 Then ' 检查是否包含“总分”
         k = k + 1
      End If
Next j
For j = 0 To UBound(ar, 2) - 3 Step k
      .Cells(c, 1) = ar(1, j + 3)
      .Cells(c, 1).Resize(1, UBound(cR)).Merge
      .Cells(c + 1, 1).Resize(1, UBound(cR)) = dr
      sD = c: c = c + 1
      For i = 3 To UBound(ar) - 1
         c = c + 1
         For Z = 1 To UBound(cR)
               If Z > 2 And Z Mod 2 = 0 Then
                  .Cells(c, Z) = Application.Rank(ar(i, j + cR(Z - 1)), sht.Cells(3, j + cR(Z - 1)).Resize(m))
                  Else
                  .Cells(c, Z) = ar(i, cR(Z))
            End If
         Next
      Next
      c = c + 1
Next
With .Range("a1").CurrentRegion
      .Borders.LineStyle = 1
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .Font.Size = 14
End With
For Each col In .Range("2:2").Columns ' 假设表头在第二行
      ' 获取表头单元格的值
      Set headerCell = col.Cells(1)
      headerText = headerCell.Value
      ' 检查表头是否包含"率"字，并设置百分比格式
      If InStr(1, headerText, "率", vbTextCompare) > 0 Then
         headerCell.EntireColumn.NumberFormat = "0.00%"
      End If
Next col
End With
End Sub

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

[求助] 请大佬帮忙根据总表生成分析表

评分

评分

评分

评分