求助，如下附件和需求，谢谢。

lgq1001

如图片中的数据，需求如下：
有附件中的数据需要处理，从不同列中找出相同的数据，经行保存，我是一个初学者，用for循环始终不能搞定。请大侠出手相助，谢谢。
就是从每一列中第三行开始，在数据中进行比对，发现有相同的就记录下来：相同值，相同值所对应的第二行和第一行的数值。在本数据中，需要获取的结果应给是：
12365  特种服务_政府部门  李斯 51111_王二 22222
010-64035547 特种服务_政府部门  李斯 51111_王二 22222
12365  特种服务 _保险公司  李斯 51111_周赛 66666
12365  政府部门_保险公司  王二 22222 _周赛 66666
12338  政府部门_保险公司  王二 22222 _周赛 66666

因数据量巨大，所以需要vba来完成，但我写的代码始终不能得到真确的结果，故求助大侠们，非常感谢。代码如下：
Sub 查找相同ID()
    Dim arrzhy, arrkyhy()
    Dim x As Long, y As Long, z As Long, H As Long, L As Long, m As Long
    Dim shthz
    Set shthz = ThisWorkbook.Sheets("汇总1")
    H = shthz.UsedRange.Rows.Count
    L = shthz.UsedRange.Columns.Count
   
    arrzhy = shthz.Range(shthz.Cells(1, 1), shthz.Cells(H, L))
   
    m = 0
    For z = 1 To L
   
        For x = 1 To L
        
            If arrzhy(2, z) = arrzhy(2, x) Then GoTo 66
                For y = 3 To H
                    If arrzhy(y, x) = "" Then GoTo 66
                    If arrzhy(y, z) = "" Then GoTo 99
                    If arrzhy(y, z) = arrzhy(y, x) Then
                        m = m + 1
                        ReDim Preserve arrkyhy(1 To m, 1 To 3)
                            arrkyhy(m, 1) = arrzhy(y, z)
                            arrkyhy(m, 2) = arrzhy(2, z) & "_" & arrzhy(2, x)
                            arrkyhy(m, 3) = arrzhy(1, z) & "_" & arrzhy(1, x)
                    End If


                Next y
66:
        Next x
99:
    Next z

   ThisWorkbook.Sheets(2).Range("B2").Resize(UBound(arrkyhy), 3) = WorksheetFunction.Transpose(arrkyhy)


Erase arrzhy
Erase arrkyhy()

Set shthz = Nothing
End Sub

清风竹-

请看附件。

chxw68

真心看不懂。

lgq1001

清风竹- 发表于 2023-4-29 10:29
请看附件。

完美解决，谢谢。

cjc209

我也看不懂