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

qlmgu

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

fzxba老师，确实有您提到的现象，如果分数为99.6，合并后就归入100了。可以修改吗？

qlmgu

fzxba 发表于 2023-4-9 20:52

测试结果很好，可以直接用百分比数据了。而且99.8%不会四舍五入，非常准确。再次感谢老师您。

qlmgu

fzxba 发表于 2023-4-9 20:52

谢谢老师。不但扩展程序为百分比数据，而且还可以体会这个语句的作用。谢谢。但是我的花数不多了，只能这样表表心意。

qlmgu

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

我现在才明白，您说的这个语句是另外一个程序里的，它会产生分数段临界分数四舍五入晋级。感谢您的指教。

fzxba

qlmgu 发表于 2023-4-9 21:35
我现在才明白，您说的这个语句是另外一个程序里的，它会产生分数段临界分数四舍五入晋级。感谢您的指教。

这叫四舍六入五单双。
用 \ 时前面的数会这样处理。

qlmgu

fzxba 发表于 2023-4-9 21:39
这叫四舍六入五单双。
用 \ 时前面的数会这样处理。

过去学分析化学时学过四舍六入五成双的方法，没想到计算机语言这么简明，一个斜杠就表示了。我不懂编程，但是对老师们太佩服了。谢谢您。

吴中泉

qlmgu 发表于 2023-4-9 20:22
感谢吴中泉老师出手相助。您的程序不仅仅是基本符合我的需求，是完全符合需求。而且您的程序分2段，一段 ...

老师不敢当,你提问题我练手.我又尝试编了一三段代码,不用字典,不用数组,实现合并\排序\拆分\删除四大功能,

貌似小数的问题也没问题.代码如下:

1. Sub 合并排序拆分多表()
   
2. '合并AB两列数据,B列放到A列尾部,c列分数相对应每个姓名
   
3.     Sheets("Sheet1").Activate
   
4.     Range("H:I").ClearContents
   
5.     [H1:I1] = Array("姓名", "分数")
   
6.     endrow = Cells(Rows.Count, "A").End(xlUp).Row
   
7.     For i = 0 To 1
   
8.         r = i * (endrow - 1)
   
9.         Range([a2], "A" & endrow).Offset(0, i).Copy Range("H2").Offset(r, 0)
   
10.         Range([a2], "A" & endrow).Offset(0, 2).Copy Range("I2").Offset(r, 0)
    
11.     Next i
    
12.     [H2].CurrentRegion.Sort key1:=[I2], order1:=2, Header:=xlNo '排序
    
13.     Call 删除分表
    
14.     Call 拆分到多表
    
15. End Sub
    
16. Sub 拆分到多表()
    
17.     Dim sht_name As New Collection, i, T
    
18.     Sheets("Sheet1").Activate
    
19.     endrow = Cells(Rows.Count, "I").End(xlUp).Row
    
20.     For i = 2 To endrow '以分数段取表名
    
21.         T = (Cells(i, "I") \ 10) * 10
    
22.         Cells(i, "J") = T
    
23.         On Error Resume Next
    
24.         sht_name.Add T, CStr(T)
    
25.     Next
    
26.     For Each T In sht_name '建立分表
    
27.         Worksheets.Add(after:=Sheets(Sheets.Count)).Name = T
    
28.     Next
    
29.     For i = 2 To Sheets.Count
    
30.         Sheets("Sheet1").Range("H1:J" & endrow).AutoFilter Field:=3, Criteria1:=Sheets(i).Name
    
31.         Sheets("Sheet1").Range("H1:I" & endrow).Copy Sheets(i).Range("a1")
    
32.     Next
    
33.     Sheets("Sheet1").Range("H1:I" & endrow).AutoFilter
    
34.     Sheets("Sheet1").Range("J1:J" & endrow).Clear
    
35.     Sheets("Sheet1").Select
    
36.     Beep
    
37.     MsgBox "已处理完毕！"
    
38. End Sub
    
39. Sub 删除分表()
    
40.     Sheets("Sheet1").Activate
    
41.     Application.DisplayAlerts = False
    
42.     For Each sht In Worksheets
    
43.         If sht.Name <> "Sheet1" Then sht.Delete
    
44.     Next
    
45.     Application.DisplayAlerts = True
    
46. End Sub
    
47. 
    
48. 
    

复制代码

qlmgu

吴中泉 发表于 2023-4-9 21:56
老师不敢当,你提问题我练手.我又尝试编了一三段代码,不用字典,不用数组,实现合并\排序\拆分\删除四大 ...

吴中泉老师，您的钻研精神也值得我学习。程序运行速度很快，很好。但是有个小意外:在分表里，临界分数段有较大小数时确实没有进位，但是归到上一等级了。

吴中泉

qlmgu 发表于 2023-4-9 22:24
吴中泉老师，您的钻研精神也值得我学习。程序运行速度很快，很好。但是有个小意外:在分表里，临界分数段 ...

把这句代码 T = (Cells(i, "I") \ 10) * 10改成以下代码:

        T = Int(Cells(i, "I") / 10) * 10

就解决四舍五入问题(向下取整),如99.6不会成为100,59.9不会成为60

qlmgu

吴中泉 发表于 2023-4-10 10:51
把这句代码 T = (Cells(i, "I") \ 10) * 10改成以下代码:

        T = Int(Cells(i, "I") / 10) * 10
...

感谢您，吴中泉老师。这次结果正确了。我的小花不够了，只能这样表达感谢。