0

私は、Excel で非常に具体的でトリッキーな状況に陥っています。基本的に、私は Outlook の連絡先のバックアップを 10 回繰り返して、それらを 1 つにまとめるという任務を負っています。私が今持っているものはこのようなものですが、90列と16,000行です...

Name    LastName    Phone1      Phone2      Email          Notes       
Bob     Jones       123456789               bob@email.com  note1
Bob     Jones       123456789               bob@email.com  note1, note2
Bob     Jones       123456789               bob@email.com  note2
Bob     Jones       123456789   0412345678  bob@email.com  note3

私がしたいのは、電子メールアドレスを照合して同様の行を選択し、電話番号の列の場合、番号が1つの行にあり、他の行では番号をすべてのレコードに複製しないことです。

メモ列の場合、一部のレコードにはいくつかのメモのチャンクがあり、他のレコードには同じチャンクにさらに追加されたメモがあり、他のレコードにはメモに追加されているだけです。基本的に、セルの内容が同じで、不足しているものだけを最後に追加する場合は解決する必要があります。

最後に、データベースを次のようにしたいと思います....

Name    LastName    Phone1      Phone2      Email          Notes       
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3

この時点で、同一の行をフィルタリングしてすべての重複を削除できます。

4

1 に答える 1

1

これでうまくいくはずですが、範囲を調整する必要があるかもしれません。

Sub Remove_Duplicate()
    Dim LASTROW As Long
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim MyVALUE As Variant
    Dim s As String, l As String
    Application.ScreenUpdating = False
    LASTROW = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LASTROW
        MyVALUE = Cells(I, "E")
        For J = LASTROW To I + 1 Step -1
            If (MyVALUE = Cells(J, "E")) Then
                For K = 1 To 4
                    If (Cells(I, K) = "") Then Cells(I, K) = Cells(J, K)
                Next K

                If (Len(Cells(I, "F").Text) >= Len(Cells(J, "F").Text)) Then
                    s = Cells(J, "F").Text
                    l = Cells(I, "F").Text
                Else
                    s = Cells(I, "F").Text
                    l = Cells(J, "F").Text
                End If
                If Not (s = l) Then
                     If InStr(l, s) = 0 Then
                         Cells(I, "F") = Cells(I, "F") & ", " & s
                     End If
                End If
                Cells(J, "A").EntireRow.Delete
            End If
        Next J
    Next I
    Application.ScreenUpdating = True
End Sub

メモはで区切られていると仮定しました。", " また、現在、重複する行を削除するように設定されていますが、代わりにそれらを強調表示するようにコードを調整することをお勧めします。

于 2013-01-31T04:59:37.467 に答える