合并列及拷贝不同分数段的数据到新工作表

qlmgu

cjc209 发表于 2023-4-9 08:36
我也来一个

虽然已经获得多个程序，但是我仍然要感谢老师出手相助。老师您的程序输出结果是更细的分数段等级，这个在我另外的场景下也有很大帮助，谢谢您。

fzxba

指标等级 是什么样的？

qlmgu

fzxba 发表于 2023-4-9 08:47
指标等级 是什么样的？

感谢fzxba关注和再次指导。简单说指标等级是百分数，文本数据的某个“度“的等级。您的软件已经非常完美了，再次感谢您。

fzxba

qlmgu 发表于 2023-4-9 08:50
感谢fzxba关注和再次指导。简单说指标等级是百分数，文本数据的某个“度“的等级。您的软件已经非常完美 ...

噢，我是想原始的数据能否一步到位，不用转成数值

qlmgu

fzxba 发表于 2023-4-9 08:52
噢，我是想原始的数据能否一步到位，不用转成数值

真的要再次表示我的感激之心，您太专业了，值得我学习。

吴中泉

qlmgu 发表于 2023-4-9 08:54
真的要再次表示我的感激之心，您太专业了，值得我学习。

综合以上各位老师的代码,并适当改进,取长补短,基本符合你的要求.


(后经测试,代码有问题,数据会出错,若使用以后面楼层发的代码为准)

1. Sub MergeAndSort() '合并列并根据分值排序
   
2.     With Sheet1
   
3.         ar = .[a1].CurrentRegion.Resize(, 3)
   
4.         ReDim arr(1 To UBound(ar) * 2 - 1, 1 To 2)
   
5.         For j = 1 To 2
   
6.             For i = 2 To UBound(ar)
   
7.                 n = n + 1
   
8.                 arr(n, 1) = ar(i, j)
   
9.                 arr(n, 2) = ar(i, 3)
   
10.             Next i
    
11.         Next j
    
12.         .Range("e:f").ClearContents
    
13.         .[e1:f1] = Array("姓名", "分数")
    
14.         .[E2].Resize(UBound(arr), 2) = arr
    
15.         .[E2].Resize(UBound(arr), 2).Sort key1:=.[f2], order1:=2, Header:=xlNo
    
16.     End With
    
17.     Call 根据分数段拆分多表
    
18. End Sub
    
19. 
    
20. Sub 根据分数段拆分多表()
    
21.     Dim i, j, n, 关键字, 关键字1 As Integer
    
22.     Dim arr, dic As Object
    
23.     Set dic = CreateObject("scripting.dictionary")
    
24.     Worksheets(1).Activate
    
25.     Application.DisplayAlerts = False
    
26.     For Each wks In Worksheets
    
27.         If wks.Name <> ActiveSheet.Name Then wks.Delete
    
28.     Next
    
29.     Application.DisplayAlerts = True
    
30.     arr = [a1].CurrentRegion
    
31.     For i = 2 To UBound(arr)
    
32.         关键字 = (arr(i, 3) \ 10) * 10
    
33.         If Not dic.exists(关键字) Then
    
34.             Set dic(关键字) = CreateObject("scripting.dictionary")
    
35.         End If
    
36.         关键字1 = arr(i, 3)
    
37.         If Not dic(关键字).exists(关键字1) Then
    
38.             dic(关键字)(关键字1) = arr(i, 1) & "," & arr(i, 2)
    
39.         Else
    
40.             dic(关键字)(关键字1) = dic(关键字)(关键字1) & "," & arr(i, 1) & "," & arr(i, 2)
    
41.         End If
    
42.     Next
    
43.     For Each 键名 In dic.keys
    
44.         Sheets.Add(after:=Sheets(Sheets.Count)).Name = 键名
    
45.         [a1] = "姓名"
    
46.         [b1] = "分数"
    
47.         n = 2
    
48.         For Each 键名1 In dic(键名).keys
    
49.             zjsz = Application.Transpose(Split(dic(键名)(键名1), ","))
    
50.             Cells(n, "A").Resize(UBound(zjsz), 1) = zjsz
    
51.             Cells(n, "B").Resize(UBound(zjsz), 1) = 键名1
    
52.             n = n + 2
    
53.         Next
    
54.     Next
    
55.     Worksheets(1).Activate
    
56.     Beep
    
57. End Sub
    
58. 
    

复制代码

合并列和拷贝数据到不同工作表1.zip (23.69 KB, 下载次数: 8)

2023-4-9 14:04 上传

点击文件名下载附件

qlmgu

吴中泉 发表于 2023-4-9 14:04
综合以上各位老师的代码,并适当改进,取长补短,基本符合你的要求.

感谢吴中泉老师出手相助。您的程序不仅仅是基本符合我的需求，是完全符合需求。而且您的程序分2段，一段实现姓名合并，第二段实现分段分表。可以合起来或者分开使用都可以。谢谢了。（后来发现临界分数有较大小数时会进位）

fzxba

(arr(i, 3) \ 10) * 10   arr(i, 3) 若是小数，如99.6 则会当100段，59.5会当60段……

qlmgu

fzxba 发表于 2023-4-9 20:34
(arr(i, 3) \ 10) * 10   arr(i, 3) 若是小数，如99.6 则会当100段，59.5会当60段……

fzxba老师您好。您的第一个程序已经很完美了。还能继续帮我考虑，真心感谢您。如果有分数档次间的四舍五入，那我还是用您第一个程序更好。如果可以使用百分比，我先试验下。谢谢了

fzxba

qlmgu 发表于 2023-4-9 20:37
fzxba老师您好。您的第一个程序已经很完美了。还能继续帮我考虑，真心感谢您。如果有分数档次间的四舍五 ...