求助，需要对大量数据进行处理

lgq1001

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

gwjkkkkk

没看懂，建议模拟一下结果。。。

lgq1001

不知道这段代码哪里出了问题，始终无法获取重复的号码。



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) = arrkyhy


Erase arrzhy
Erase arrkyhy()

Set shthz = Nothing
End Sub

ykcbf1100

没看懂。
求助时应该清楚说明取数的规则。

lgq1001

就是要找到相同的电话，如12365

cpin

lgq1001 发表于 2023-4-28 21:33
就是要找到相同的电话，如12365

参考一下：

Option Explicit
Option Base 1


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 As Worksheet
   
    Dim a
    Dim b
    Dim c
   
    Set shthz = ThisWorkbook.Sheets("汇总1")
    H = shthz.UsedRange.Rows.Count
    L = shthz.UsedRange.Columns.Count
   
    ReDim arrkyhy(1 To H, 1 To 4)
   
    arrzhy = shthz.Range(shthz.Cells(1, 1), shthz.Cells(H, L))
  
    m = 0
    For z = 3 To H
        a = arrzhy(z, 1)
        For x = 3 To H
            b = arrzhy(x, 2)
            If a = b Then
                For y = 3 To H
                        c = arrzhy(y, 3)
                    If b = c Then
                        m = m + 1
                            arrkyhy(m, 1) = arrzhy(y, 3)
                            arrkyhy(m, 2) = arrzhy(2, 1) & "_" & arrzhy(1, 1)
                            arrkyhy(m, 3) = arrzhy(2, 2) & "_" & arrzhy(1, 2)
                            arrkyhy(m, 4) = arrzhy(2, 3) & "_" & arrzhy(1, 3)
                    End If
                Next
           End If
        Next
    Next

   ThisWorkbook.Sheets(2).Range("B2").Resize(H, 4) = arrkyhy

Erase arrzhy
Erase arrkyhy()

Set shthz = Nothing
End Sub

fzxba

测试.rar (22.1 KB, 下载次数: 10)

2023-4-29 07:58 上传

点击文件名下载附件

lgq1001

fzxba 发表于 2023-4-29 07:58

完美解决，谢谢