Finden Dupes in einer Spalte Basis auf Werte in einem anderen

Question

Ich hoffe, dass jemand kann mir dabei helfen. Ich habe einen Screenshot angehängt. Die 2 rechten Spalten sind Postleitzahlen. Die Spalten ganz rechts sind doppelte Postleitzahlen in der Spalte links. Aber es greift nach allen Zip-Betrogenen.

Die andere Sache, die ich benötige Duples von bestimmten Datum. Also nur für 6/7 und nur für 6/9. Mein Code ist unten. Nicht sicher, was ich vermisse.

Sub ListDuplicatedZipsInColumnI() 

    Dim strCurrentRowZips As String 
    Dim strCurrentRowZipArray() As String 

    Dim foundZips As String 

    Dim zipCell As String 
    Dim foundCell As String 
    Dim allZipCell As String 



    Dim sht As Worksheet 
    Dim LastRow As Long 
    'Ctrl + Shift + End 
    Set sht = ActiveSheet 
    'Set sht = ThisWorkbook.Worksheets("Sheet1") 
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 

    Dim firstDataRowNum As Integer 
    firstDataRowNum = 2 

    For RowNum = firstDataRowNum To LastRow 
    zipCell = "H" & RowNum 
    foundCell = "I" & RowNum 

    Dim strAllExceptCurrentRowZips As String 
    Dim strAllExceptCurrentRowZipArray() As String 
    'NEW CODE START**** 
    Dim RowNum_C As Long, LastRow_C As Long 
'turn off screen updating 
''Application.ScreenUpdating = False 
'start below titles and make full selection of data 
RowNum_C = 2 
LastRow_C = Cells.SpecialCells(xlCellTypeLastCell).Row 
Range("A2", Cells(LastRow_C, 4)).Select 
    'NEW CODE END**** 

    strAllExceptCurrentRowZips = "" 


      'NEW CODE START**** 
       For Each Row In Selection 
    With Cells 

    If Cells(RowNum_C, 2) = Cells(RowNum_C + 1, 2) Then 


      ' move attribute 2 up next to attribute 1 and delete empty line 
      Cells(RowNum_C + 1, 9).Copy Destination:=Cells(RowNum_C, 10) 
      Rows(RowNum_C + 1).EntireRow.Delete 
    ' End If 
    End If 
    ' End With 
'increase RowNum_C for next test 
RowNum_C = RowNum_C + 1 
Next Row 

       'NEW CODE END **** 
'   If allRowNum <> RowNum Then 
'     allZipCell = "H" & allRowNum 
' 
'     If (LTrim(RTrim(Range(allZipCell).Value)) <> "") Then 
'     strAllExceptCurrentRowZips = Replace(strAllExceptCurrentRowZips, " ", "") & "," & Replace(Range(allZipCell).Value, " ", "") 
' 
'     End If 
'   End If 
'   End If 
' Next 


    foundZips = "" 

    strArray = Split(Replace(Range(zipCell).Value, " ", ""), ",") 

    For intCount = LBound(strArray) To UBound(strArray) 
     Debug.Print Trim(strArray(intCount)) 
     If InStr(strAllExceptCurrentRowZips, strArray(intCount)) > 0 Then 
     If Len(foundZips) > 0 Then 
      foundZips = foundZips & ", " 
     End If 
     foundZips = foundZips & strArray(intCount) 
     End If 

    Next 

    Range(foundCell).Value = "'" & foundZips 

    Next 


End Sub 

Answer 1

Wie wäre es nur für jene Tage zu überprüfen, bevor Sie Ihre de-duping tun. Gefällt dir so

if Range("A" & RowNum) = "6/7/2016" or Range("A" & RowNum) = "6/9/2016" then  
    strArray = Split(Replace(Range(zipCell).Value, " ", ""), ",") 

    For intCount = LBound(strArray) To UBound(strArray) 
     Debug.Print Trim(strArray(intCount)) 
     If InStr(strAllExceptCurrentRowZips, strArray(intCount)) > 0 Then 
      If Len(foundZips) > 0 Then 
       foundZips = foundZips & ", " 
      End If 
      foundZips = foundZips & strArray(intCount) 
     End If 
    Next 
End If