求助vba代码

夕阳的刻痕666 · 发表于 2024-6-30 11:42

wang-way 发表于 2024-6-30 01:48
多重循环就可以解了

谢谢，楼上的代码可以使用了，就是时间会有点慢，大佬有什么优化方法吗

wang-way · 发表于 2024-6-30 11:43

夕阳的刻痕666 发表于 2024-6-30 11:40
测试是大量的嵌套循环时间指数级上升

你这个多重循环就可以了，不用嵌套字典。或者用一个一点来记录输出数组的行号就可以

wang-way · 发表于 2024-6-30 11:46

用一个字典记录输出数组的行号，就可以了。

夕阳的刻痕666 · 发表于 2024-6-30 13:44

准提部林发表于 2024-6-30 10:59
資料分拆為一維//by.准提部林
用了輔助排序法//

这个效率很高啊，秒完成！正在测试

ynzsvt · 发表于 2024-6-30 14:09

本帖最后由 ynzsvt 于 2024-6-30 16:11 编辑

夕阳的刻痕666 发表于 2024-6-30 13:44
这个效率很高啊，秒完成！正在测试

注意已知的日期升序，否则出乱子。

夕阳的刻痕666 · 发表于 2024-6-30 20:24

ynzsvt 发表于 2024-6-30 14:09
注意已知的日期升序，否则出乱子。

谢谢提醒，我会根据大佬的代码酌情修改

wang-way · 发表于 2024-6-30 20:29

麻烦验证一下效率

Public Sub 数组方法()
''关闭警示弹窗
Dim dStart, dCount
Application.DisplayAlerts = False
Dim wb As Workbook, sht As Worksheet, psht As Worksheet
Set dStart = CreateObject("Scripting.Dictionary")
Set dCount = CreateObject("Scripting.Dictionary")
Set wb = Application.ThisWorkbook
Set sht = wb.Worksheets(1)
With sht
eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range("A1").CurrentRegion
arr = rng.Value
Dim br(1 To 10000, 1 To 6)
r = 0
For i = LBound(arr) To UBound(arr)
If IsDate(arr(i, 1)) Then
dat = Format(arr(i, 1), "yyyy/mm/dd")
Else
'''存入数据行
For j = 4 To UBound(arr, 2) Step 2
If arr(i, j) <> "" Then
r = r + 1
br(r, 1) = arr(i, 1)
br(r, 2) = arr(i, 2)
br(r, 3) = arr(i, 3)
br(r, 4) = arr(i, j)
br(r, 5) = arr(i, j + 1)
br(r, 6) = dat
If Not dStart.Exists(br(r, 1) & br(r, 6)) Then dStart(br(r, 1) & br(r, 6)) = "A" & r
If Not dStart.Exists(br(r, 1) & br(r, 2) & br(r, 6)) Then dStart(br(r, 1) & br(r, 2) & br(r, 6)) = "B" & r
dCount(br(r, 1) & br(r, 6)) = dCount(br(r, 1) & br(r, 6)) + 1
dCount(br(r, 1) & br(r, 2) & br(r, 6)) = dCount(br(r, 1) & br(r, 2) & br(r, 6)) + 1
End If
Next j
End If
Next i
End With
Set sht = wb.Worksheets(2)
With sht
.Cells.Clear
.Range("a1").Resize(UBound(br), UBound(br, 2)).Value = br
'边框居中
.UsedRange.Borders.LineStyle = 1
.UsedRange.HorizontalAlignment = 3
.Sort.SortFields.Clear
.Sort.SetRange .UsedRange
.Sort.SortFields.Add Key:=.UsedRange.Columns(6), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.UsedRange.Columns(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.UsedRange.Columns(2), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.Apply
For Each k In dStart
.Range(dStart(k)).Resize(dCount(k), 1).Merge
Next k
End With
''恢复警示弹窗
Application.DisplayAlerts = True
End Sub
''代码功能：对目标单元格区域进行按行排序
'''参数【sht】：目标工作表
'''参数【rng】：目标单元格区域
'''参数【cols 】：排序的列号与升降序的数组如Array(array(1,True)) True为升序
'''参数【header】：目标单元格区域是否包含表头
'''调用示范：sort2007 sht,rng,array(array(1,true))
Sub Sort2007(ByVal sht As Worksheet, ByVal rng As Range, ByVal cols As Variant, Optional header = True)
With sht
'''操作Sort对象，升序xlAscending, 降序xlDescending
With .Sort
'''清除排序字段
.SortFields.Clear
'''添加排序字段，Rng.Columns(1)为目标单元格区域的第1列，按需修改
For Each cs In cols
.SortFields.Add Key:=rng.Columns(cs(0)), _
SortOn:=xlSortOnValues, _
Order:=IIf(cs(1), xlAscending, xlDescending), _
DataOption:=xlSortNormal
Next
'''设置目标单元格区域
.SetRange rng
'''目标单元格区域是否包含表头 xlYes, xlNo
If header Then
.header = xlYes
Else
.header = xlNo
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

复制代码

ynzsvt · 发表于 2024-6-30 20:33

夕阳的刻痕666 发表于 2024-6-30 20:24
谢谢提醒，我会根据大佬的代码酌情修改

我的代码用类来记录输出的数据的行号的。也是万级别数据秒出结果。

wang-way · 发表于 2024-6-30 22:20

ynzsvt 发表于 2024-6-30 20:33
我的代码用类来记录输出的数据的行号的。也是万级别数据秒出结果。

只要少嵌套，效率不会低。

准提部林 · 发表于 2024-7-1 12:00

ynzsvt 发表于 2024-6-30 14:09
注意已知的日期升序，否则出乱子。

規範統一的日期格式, 訂好排序準則, 應不會有問題, 也更有彈性\\

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

[求助] 求助vba代码