Question

我希望有人可以帮我解决这个问题。我附了一个屏幕截图。右边2列是邮政编码。最右边的列是位于左侧列中的重复邮政编码。但它抓住了所有的拉链。

另一件事我需要从具体日期开始。因此仅适用于6/7且仅适用于6/9。我的代码如下。不确定我错过了什么。

   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

如何在进行重复数据删除之前检查一下。像这样

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

根据另一列中的值在一列中查找Dupes

1 个答案: