[已解决]求助：数据按大小分组后再归类

梨园的戏 · 发表于 2015-3-10 16:57

有大量随机数据，要找出最大和最小值，然后按最大和最小值等分成x组（比如40组），然后把所有数据按大小归类到各自x组中去。根据例子数据处理，第三列中的Mx为目标，第一和第二列一起归类。

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-12 06:01

Sub Macro1()
On Error Resume Next
Dim arr, wb As Workbook, i%, j&, k&
Set wb = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'保留界面工作表，删除多余表
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> "界面" Then Sheets(i).Delete
Next
n = Val(Application.InputBox("请输入组数"))
'获得最大数和最小数，方便分组
mymax = 0: mymin = 10 ^ 8
With Workbooks.Open(ThisWorkbook.Path & "\原始数据.xls")
For i = 1 To .Sheets.Count
arr = .Sheets(i).Range("a1").CurrentRegion
For j = 2 To UBound(arr)
If arr(j, 3) > mymax Then mymax = arr(j, 3)
If arr(j, 3) < mymin Then mymin = arr(j, 3)
Next
Next
.Close False
End With
'分组，命名工作表名称
s = Round((mymax - mymin) / n, 3)
For k = mymin To mymax + 0.1 * s Step s
With Sheets.Add(after:=Sheets(Sheets.Count))
[a1:c1] = "标题"
ActiveSheet.Name = k + s & "以下"
End With
Next
With Workbooks.Open(ThisWorkbook.Path & "\原始数据.xls")
For i = 1 To .Sheets.Count
arr = .Sheets(i).Range("a1").CurrentRegion
For j = 2 To UBound(arr)
n2 = (arr(j, 3) - mymin) \ s + 2
h = wb.Sheets(n2).Cells(65536, 1).End(xlUp).Row + 1
.Sheets(i).Cells(j, 1).Resize(1, 3).Copy wb.Sheets(n2).Cells(h, 1)
Next
Next
.Close False
End With
Sheets("界面").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

跳转到最佳答案楼层

梨园的戏 · 发表于 2015-3-11 13:27

让高手来解决

梨园的戏 · 发表于 2015-3-11 15:12

附件包含原始数据和处理后效果的数据，真实中数据量比较大，有几百万行不能合并到一个sheet中，只能一个一个sheet搜索，求助。。。

pengyx · 发表于 2015-3-11 21:35

实际上并没有搞懂你的结果是如何计算的。1、分成X组，用什么条件分2、按大小规到X组中去，具体归类的对应关系没说清楚。简单地说，多大的数归在第一组，多大的数又归第二驵？

梨园的戏 · 发表于 2015-3-11 22:04

不好意思，没有表达清楚，就是找出所有sheet第三列数据的最大和最小值，然后按最大（9）和最小值（0.1）平均分成x组（4组），4组范围分别就是（0.1~2.325）、（2.325~4.55）、（4.55~6.775）、（6.775~9），然后按第三数据按大小归类到4组中其中一组去。其中2.325=（（9-0.1）/4）+0.1，4.55=（（9-0.1）/4）*2+0.1，6.775=（（9-0.1）/4）*3+0.1。不知道这样是否表达清楚了。

dsmch · 发表于 2015-3-12 06:01

Sub Macro1()
On Error Resume Next
Dim arr, wb As Workbook, i%, j&, k&
Set wb = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'保留界面工作表，删除多余表
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> "界面" Then Sheets(i).Delete
Next
n = Val(Application.InputBox("请输入组数"))
'获得最大数和最小数，方便分组
mymax = 0: mymin = 10 ^ 8
With Workbooks.Open(ThisWorkbook.Path & "\原始数据.xls")
For i = 1 To .Sheets.Count
arr = .Sheets(i).Range("a1").CurrentRegion
For j = 2 To UBound(arr)
If arr(j, 3) > mymax Then mymax = arr(j, 3)
If arr(j, 3) < mymin Then mymin = arr(j, 3)
Next
Next
.Close False
End With
'分组，命名工作表名称
s = Round((mymax - mymin) / n, 3)
For k = mymin To mymax + 0.1 * s Step s
With Sheets.Add(after:=Sheets(Sheets.Count))
[a1:c1] = "标题"
ActiveSheet.Name = k + s & "以下"
End With
Next
With Workbooks.Open(ThisWorkbook.Path & "\原始数据.xls")
For i = 1 To .Sheets.Count
arr = .Sheets(i).Range("a1").CurrentRegion
For j = 2 To UBound(arr)
n2 = (arr(j, 3) - mymin) \ s + 2
h = wb.Sheets(n2).Cells(65536, 1).End(xlUp).Row + 1
.Sheets(i).Cells(j, 1).Resize(1, 3).Copy wb.Sheets(n2).Cells(h, 1)
Next
Next
.Close False
End With
Sheets("界面").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2015-3-12 06:07

楼主的分组并不能涵盖所有数据，比如，第一张表0.1~2.325 ，大于等于0.1同时小于2.325，这样最大数9就会漏掉，附件多出一组

梨园的戏 · 发表于 2015-3-13 08:24

不好意思，来晚了，谢谢dsmch

梨园的戏 · 发表于 2015-3-13 08:32

不知道是否可以追加问题，当要分组的数据中有负数时好像不对啊，dsmch能否改进下？

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

[已解决]求助：数据按大小分组后再归类

点评

点评