成绩条制作

user湫

原本是想着WPS有这个工资条的功能但是只能做一个的，不能有多个数据就自己写了一部分，AI优化了一部分
使用的是最简单的方法，筛选和复制所以会等待比较长时间，肯定有更好的方法，时间原因就随便做了一个，能用就行。分享一下然后看看有没有大佬优化

1. Sub ProcessUniqueValues()
   
2.     Dim inputColumn As String, activeSheetName As String
   
3.     Dim lastRow As Long
   
4.    
   
5.     inputColumn = InputBox("请输入姓名所在的列（输入字母）")
   
6.     activeSheetName = ActiveWorkbook.ActiveSheet.Name
   
7.    
   
8.     ' 获取最大行
   
9.     lastRow = Sheets(activeSheetName).Cells(Rows.Count, 1).End(xlUp).Row
   
10.    
    
11.     If lastRow < 2 Or Trim(inputColumn) = "" Then
    
12.         MsgBox "请检查当前激活工作表数据，参照模板", vbExclamation
    
13.         Exit Sub
    
14.     End If
    
15.    
    
16.     Application.ScreenUpdating = False
    
17.    
    
18.     Call ExtractUniqueValues(inputColumn & "2:" & inputColumn & lastRow, activeSheetName, lastRow)
    
19.    
    
20.     Rows("1:2").Delete Shift:=xlShiftUp
    
21.     Application.ScreenUpdating = True
    
22.     Call dy
    
23. End Sub
    
24. 
    
25. Sub ExtractUniqueValues(inputRange As String, activeSheetName As String, lastRow As Long)
    
26.     Dim rng As Range
    
27.     Dim uniqueValues As Variant
    
28.     Dim i As Long
    
29.     Dim lastUsedRow As Long
    
30.     Dim outputSheet As Worksheet
    
31.    
    
32.     ' 检查用户输入的范围
    
33.     If Trim(inputRange) = "" Then
    
34.         MsgBox "您没有输入范围。", vbExclamation
    
35.         Exit Sub
    
36.     End If
    
37.    
    
38.     ' 设置范围
    
39.     On Error Resume Next
    
40.     Set rng = Range(inputRange)
    
41.     On Error GoTo 0
    
42.    
    
43.     If rng Is Nothing Then
    
44.         MsgBox "输入的范围无效，请检查后重试。", vbExclamation
    
45.         Exit Sub
    
46.     End If
    
47.    
    
48.     ' 创建新工作表
    
49.     Set outputSheet = ThisWorkbook.Worksheets.Add
    
50.     outputSheet.Name = "成绩条" & Format(Now, "yyyymmddhhmmss")
    
51.    
    
52.     ' 获取唯一值
    
53.     uniqueValues = GetUniqueValues(rng)
    
54.    
    
55.     ' 过滤和复制数据
    
56.     With Sheets(activeSheetName)
    
57.         .Range("A1").AutoFilter
    
58.         Dim lastColumn As String
    
59.         lastColumn = GetLastUsedColumnLetter(activeSheetName)
    
60.         
    
61.         For i = LBound(uniqueValues) To UBound(uniqueValues)
    
62.             .Range("A1:" & lastColumn & lastRow).AutoFilter Field:=2, Criteria1:=Array(uniqueValues(i)), Operator:=xlFilterValues
    
63.             
    
64.             lastUsedRow = .Cells(Rows.Count, 1).End(xlUp).Row
    
65.             .Range("A1:" & lastColumn & lastUsedRow).Copy
    
66.             
    
67.             Dim outputRow As Long
    
68.             outputRow = outputSheet.Cells(Rows.Count, 1).End(xlUp).Row + 3
    
69.             outputSheet.Range("A" & outputRow).PasteSpecial
    
70.             
    
71.             With outputSheet.Range("A" & outputRow + 3 & ":" & lastColumn & outputRow + 3).Borders(xlEdgeBottom)
    
72.                 .Weight = xlMedium
    
73.                 .LineStyle = xlDash
    
74.             End With
    
75.         Next i
    
76.         
    
77.         .Range("A1").AutoFilter
    
78.     End With
    
79. End Sub
    
80. 
    
81. Function GetUniqueValues(rng As Range) As Variant
    
82.     Dim cell As Range
    
83.     Dim uniqueCollection As Collection
    
84.     Dim uniqueArray() As Variant
    
85.     Dim i As Long
    
86.    
    
87.     Set uniqueCollection = New Collection
    
88.     On Error Resume Next ' 忽略错误以避免重复值引发的错误
    
89.    
    
90.     For Each cell In rng
    
91.         If Not IsEmpty(cell.Value) Then
    
92.             uniqueCollection.Add cell.Value, CStr(cell.Value)
    
93.         End If
    
94.     Next cell
    
95.    
    
96.     On Error GoTo 0 ' 恢复默认错误处理
    
97.    
    
98.     ReDim uniqueArray(0 To uniqueCollection.Count - 1)
    
99.     For i = 1 To uniqueCollection.Count
    
100.         uniqueArray(i - 1) = uniqueCollection(i)
     
101.     Next i
     
102.    
     
103.     GetUniqueValues = uniqueArray
     
104. End Function
     
105. 
     
106. Function GetLastUsedColumnLetter(sheetName As String) As String
     
107.     Dim lastColumn As Long
     
108.     lastColumn = Sheets(sheetName).Cells(1, Columns.Count).End(xlToLeft).Column
     
109.     GetLastUsedColumnLetter = Split(Cells(1, lastColumn).Address, "$")(1)
     
110. End Function
     
111. 
     
112. Sub dy()
     
113.     ActiveSheet.PageSetup.LeftMargin = 18
     
114.     ActiveSheet.PageSetup.RightMargin = 18
     
115.     ActiveSheet.PageSetup.TopMargin = 54
     
116.     ActiveSheet.PageSetup.BottomMargin = 54
     
117.     ActiveSheet.PageSetup.HeaderMargin = 21.5
     
118.     ActiveSheet.PageSetup.FooterMargin = 21.5
     
119.     ActiveSheet.PageSetup.FitToPagesWide = 1
     
120.     ActiveSheet.PageSetup.FitToPagesTall = 0
     
121.     ActiveSheet.PageSetup.BottomMargin = 42.519685
     
122.     ActiveSheet.PageSetup.TopMargin = 39.685039
     
123. End Sub
     
124. 
     

复制代码

LIUZHU

感觉写的很繁琐，哪里要这么多代码？

user湫

LIUZHU 发表于 2024-11-27 11:26
感觉写的很繁琐，哪里要这么多代码？

我比较业余 所以写代码不是很规范 就是兴趣爱好 优化我感觉肯定还可以 所以发出来看看有没有大佬进行优化然后学习学习

LIUZHU

JSA代码，供参考，适合WPS

1. function 生成成绩条(){
   
2.         const arr=Sheets.Item("模板").Range("a1").CurrentRegion.Value2;
   
3.         const obj=arr.slice(1).reduce((obj,x)=>{
   
4.                 let key=x[1];
   
5.                 let temp=obj[key]=obj[key] || [arr[0]];
   
6.                 temp.length==1?temp.push(x):temp.push(x,[],[]);
   
7.                 return obj;
   
8.         },{});
   
9.         const res=Object.values(obj).flat();
   
10.         Sheets.Item("成绩条").Activate();
    
11.         Cells.Delete();
    
12.         const rng=Range("a2").Resize(res.length, res[0].length);
    
13.         rng.NumberFormatLocal="@", rng.HorizontalAlignment=xlHAlignCenter;
    
14.         Range("a2").Resize(res.length, res[0].length).Value2=res;
    
15.         [...Range("a1").Resize(res.length,1)].forEach(rg=>{
    
16.                 if (rg.Value2!="批次") return;
    
17.                 rg.CurrentRegion.Borders.LineStyle=xlContinuous;
    
18.                 rg.Resize(1,res[0].length).Font.Bold=true;
    
19.                 rg.Offset(3,0).Resize(1,res[0].length).Borders.Item(xlEdgeBottom).Weight=xlMedium;
    
20.                 rg.Offset(3,0).Resize(1,res[0].length).Borders.Item(xlEdgeBottom).LineStyle=xlDash;
    
21.         });
    
22. }

复制代码

LIUZHU

执行效果如下

LIUZHU

代码比VBA简单

user湫

LIUZHU 发表于 2024-11-27 15:02
JSA代码，供参考，适合WPS

JSA是js和vba的结合体吗？简洁了很多突然感觉我的又臭又长
不太会js，只会简单的 感谢大佬解答 用ai解释学习一下

cjc209

用自定义框架函数主体就2句代码 剩下的就是美化了
function 生成成绩条(){
        var arr=maxArray_Z("模板!a1:n1").sortByCols_Z("f2",1);
    toMatrix_Z(arr.slice(1),2,1,"r",5,14,arr.slice(0,1)).toRange_Z("成绩条!a2");

}

cjc209

其实就是一个排版的问题

user湫

cjc209 发表于 2024-11-27 20:40
用自定义框架函数主体就2句代码 剩下的就是美化了
function 生成成绩条(){
        var arr=maxArray_Z("模板!a1 ...

有点看不懂 而且会报错