[已解决]提取一列值相同对应另列值不同对应的行号到另一表格中

vba77

各位大神：              附表中按【明细】的【子件图号】（B列）进行对应【子件名称】（C列）进行数据统计，如果【子件图号】相同，而对应的【子件名称】不同，则将结果插入新表【图号重复明细】中，具体结果详见下图。
       在论坛里没找到对应的帖子，刚学VBA，应用还不熟练，这个应用不知道如何写代码，还望各位不吝赐教！

[img]blob:http://www.excelpx.com/de07cc28-fb71-4ebd-949d-748ed1fb0f59[/img]

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-1-5 08:42

vba77 发表于 2022-1-5 11:10
谢谢你，但是运行的结果不是我想要的结果。应该是我没达清楚，我的需求是：
1、只要【子件图号】相同， ...

不好意思，已更新，請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[a1].CurrentRegion
n = 1
For i = 1 To UBound(Arr)
    T = Arr(i, 2)
    If xD.Exists(T) Then
        If xD(T)(1) <> Arr(i, 3) Then
            If Not xD.Exists(T & "|ar") Then
                Arr(n, 1) = T
                Arr(n, 2) = xD(T)(0) & "," & Arr(i, 1)
                xD(T & "|ar") = n: n = n + 1
            Else
                m = xD(T & "|ar")
                Arr(m, 2) = Arr(m, 2) & "," & Arr(i, 1)
            End If
        End If
    Else
        xD(T) = Array(Arr(i, 1), Arr(i, 3))
    End If
Next
If n > 0 Then
    With Sheet2
        .[a1].CurrentRegion.Offset(1) = ""
        .[a2].Resize(n - 1, 2) = Arr
    End With
End If
End Sub

跳转到最佳答案楼层

sam-wang

vba77 发表于 2022-1-5 11:10
谢谢你，但是运行的结果不是我想要的结果。应该是我没达清楚，我的需求是：
1、只要【子件图号】相同， ...

不好意思，已更新，請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[a1].CurrentRegion
n = 1
For i = 1 To UBound(Arr)
    T = Arr(i, 2)
    If xD.Exists(T) Then
        If xD(T)(1) <> Arr(i, 3) Then
            If Not xD.Exists(T & "|ar") Then
                Arr(n, 1) = T
                Arr(n, 2) = xD(T)(0) & "," & Arr(i, 1)
                xD(T & "|ar") = n: n = n + 1
            Else
                m = xD(T & "|ar")
                Arr(m, 2) = Arr(m, 2) & "," & Arr(i, 1)
            End If
        End If
    Else
        xD(T) = Array(Arr(i, 1), Arr(i, 3))
    End If
Next
If n > 0 Then
    With Sheet2
        .[a1].CurrentRegion.Offset(1) = ""
        .[a2].Resize(n - 1, 2) = Arr
    End With
End If
End Sub

sam-wang

则将结果插入新表【图号重复明细】中，具体结果详见下图。

>> 看不見下圖，所以結果要如何呈現? 請說明，謝謝

vba77

sam-wang 发表于 2022-1-5 09:51
则将结果插入新表【图号重复明细】中，具体结果详见下图。
>> 看不見下圖，所以結果要如何呈現? 請說明， ..

想要的结果如下图，附件表里的【图号重复明细】也有写对应的结果说明！谢谢

sam-wang

vba77 发表于 2022-1-5 10:04
想要的结果如下图，附件表里的【图号重复明细】也有写对应的结果说明！谢谢

是這樣嗎? 請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[a1].CurrentRegion
For i = 1 To UBound(Arr)
    T = Arr(i, 2)
    If xD.Exists(T) Then
        If Arr(i, 3) <> xD(T) Then
            n = n + 1: Arr(n, 1) = T: Arr(n, 2) = i
        End If
    Else
        xD(T) = Arr(i, 3)
    End If
Next
If n > 0 Then Sheet2.[a2].Resize(n, 2) = Arr
End Sub

vba77

sam-wang 发表于 2022-1-5 10:14
是這樣嗎? 請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&

谢谢你，但是运行的结果不是我想要的结果。应该是我没达清楚，我的需求是：
1、只要【子件图号】相同，但【子件名称】不同的明细就要，如下图，一个图号就会有三条记录；但您的代码只会留有后面二条记录；
2、明细要取的不是行号，是【序号】（A列），抱歉这个原本讲错了；
3、提取后的明细，【子件图号】只显示一条，在【重复行号】里将对应的序号一并显示，通过【，】隔开。
以上的，麻烦您再修改下，谢谢！

vba77

sam-wang 发表于 2022-1-5 11:47
不好意思，已更新，請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&

代码正确，完全符合我想要的，非常感谢您！

vba77

sam-wang 发表于 2022-1-5 08:42
不好意思，已更新，請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, n%, i&

想再问您一下：您的代码对数据的单元格式有要求吗？我在表格后面添加列之后，这个代码就报错了，提示”运行时错误‘1004’，应用程序定义或对象定义错误“。提示错误的代码是： .[a2].Resize(n-1,2)=Arr这里。

sam-wang

vba77 发表于 2022-1-7 09:56
想再问您一下：您的代码对数据的单元格式有要求吗？我在表格后面添加列之后，这个代码就报错了，提示”运 ...

您的代码对数据的单元格式有要求吗？>> 沒有

我猜是工作表有異動的問題，

或者請您提供檔案我在確認

感謝

vba77

sam-wang 发表于 2022-1-7 10:02
您的代码对数据的单元格式有要求吗？>> 沒有
我猜是工作表有異動的問題，
或者請您提供檔案我在確認

我上传表格了，麻烦您看一下问题出在哪里？