请高手做个循环合并四段VBA(感谢所有回帖的高手）

阿力力

请高手将附件内的四段类似VBA,做个循环合并成一个VBA，谢谢！

grf1973

，，，，，，，，，，

LIUZHU

JSA做的，速度更快，需要WPS才能运行

LIUZHU

请用WPS软件测试

阿力力

LIUZHU 发表于 2022-12-9 16:04
请用WPS软件测试

谢谢大师，没用过wps

阿力力

grf1973 发表于 2022-12-9 15:59
，，，，，，，，，，

br = Range("xrng").CurrentRegion
提示：运行错误1004，作用对象失败，大师给上传个做好的表上来哇。

半百

阿力力 发表于 2022-12-9 16:28
br = Range("xrng").CurrentRegion
提示：运行错误1004，作用对象失败，大师给上传个做好的表上来哇。

br = Range("xrng").CurrentRegion
人家的代码里没有双引号

阿力力

半百 发表于 2022-12-9 17:04
br = Range("xrng").CurrentRegion
人家的代码里没有双引号

谢谢高手。看眼花了。

阿力力

半百 发表于 2022-12-9 17:04
br = Range("xrng").CurrentRegion
人家的代码里没有双引号

大师，谢谢，搞定。有个col+1,忘记写了。

xingqiliu666

Sub 循环()
    Dim tim: tim = Timer
    Range("r3:u65536").ClearContents
    Dim ar, cr, i%, j%, t%, temp
    ar = Range("c3:h" & [c65536].End(xlUp).Row)
    temp = Array("ga1:gp3", "gr1:hb3", "hd1:hn3", "hp1:hz3")
    ReDim cr(1 To UBound(ar), 1 To 4)
    For t = 1 To 4
        br = Range(temp(t - 1)).CurrentRegion
        For i = 1 To UBound(ar)
           For j = 1 To UBound(br, 2)
            n = 0
              For k = 1 To UBound(br)
                 For x = 1 To UBound(ar, 2)
                    If br(k, j) = ar(i, x) Then
                      n = n + 1
                      Exit For
                    End If
                 Next
              Next
              If n > 0 Then y = y + 1
           Next
            cr(i, t) = y
           y = 0
        Next
    Next
    Cells(3, 18).Resize(UBound(cr, 1), UBound(cr, 2)) = cr
    [a1] = Format(Timer - tim, "0.00") & "秒"
End Sub