数据组合的问题

杨小妹

附件 组合附件.rar (228.41 KB, 下载次数: 16)

2024-9-10 14:20 上传

点击文件名下载附件

谢谢老师！

kevinchengcw

Sub test()
Dim Arr, N&, I&, P&, T&, R&, K&, Arrt, mTimer#
mTimer = Timer
Application.ScreenUpdating = False
Arr = Range("b1:b" & Cells(Rows.Count, 2).End(3).Row).Value
ReDim Arrt(1 To 1000, 1 To 2)
I = LBound(Arr): R = 1
For N = LBound(Arr) To UBound(Arr) - 1
  If Arr(N, 1) > Arr(N + 1, 1) Then
    K = 0
    For T = N To I + 1 Step -1
      For P = I To T - 1
        K = K + 1: Arrt(K, 1) = Arr(T, 1): Arrt(K, 2) = Arr(P, 1)
        If K = UBound(Arrt) Then _
          Cells(R, 17).Resize(K).Value = Arrt: R = R + K: K = 0
      Next P
    Next T
    If K > 0 Then Cells(R, 17).Resize(K, UBound(Arrt, 2)).Value = Arrt: R = R + K
    I = N + 1
  End If
Next N
Application.ScreenUpdating = True
Debug.Print Timer - mTimer
End Sub

chxw68

详见附件。

longwin

小凡、、、

叠起来数据有十多万行