请老师更改下代码

三票

Sub Match_1()
Dim t
Dim Arr, a
Dim Brr, b
Dim Crr, c
t = Timer
With Sheet1
Arr = .Cells(1, 2).CurrentRegion
Brr = .Cells(1, 6).CurrentRegion
ReDim Crr(1 To UBound(Arr) * UBound(Brr), 1 To 5)
a = 1: b = 1: c = 0
Do While a < UBound(Arr)
    b = 1
    Do While b < UBound(Brr)
        If Arr(a, 3) = Brr(b, 1) Then
            c = c + 1
            Crr(c, 1) = Arr(a, 1): Crr(c, 2) = Arr(a, 2): Crr(c, 3) = Arr(a, 3)
            Crr(c, 4) = Brr(b, 2): Crr(c, 5) = Brr(b, 3)
        End If
        b = b + 1
    Loop
    a = a + 1
Loop
.Columns("J:N").ClearContents
.Cells(1, 10).Resize(c, 5) = Crr
End With
MsgBox (Timer - t)
End Sub

abc123281

代码仅供测试参考
Sub test()
Dim arr, brr(1 To 10000, 1 To 6)
With Worksheets("第一种条件")
   r = .[b65536].End(xlUp).Row
   arr = .Range("b1:h" & r)
   For i = 1 To UBound(arr)
     If arr(i, 3) < arr(i, 5) Then
        n = n + 1
        For j = 1 To 3
          brr(n, j) = arr(i, j)
        Next
        For j = 5 To 7
          brr(n, j - 1) = arr(i, j)
        Next
      End If
   Next
End With
With Worksheets("第一种条件")
  .[j1].Resize(n, 6) = brr
End With
End Sub

三票

abc123281 发表于 2018-9-7 10:00
代码仅供测试参考
Sub test()
Dim arr, brr(1 To 10000, 1 To 6)

测试不行啊

abc123281

更改下代码数组应用.rar (37.94 KB, 下载次数: 6)

2018-9-7 11:57 上传

点击文件名下载附件

三票

abc123281 发表于 2018-9-7 11:57

非常感谢，成功了！！

三票

abc123281 发表于 2018-9-7 11:57

为什么有不组合的