0

我不敢相信这是多么困难。我想找到所有重复的行。A:R 列，动态行数。我知道如何删除行。但我只想强调它们。如果有帮助，我的数据在列表对象（表）中。不！我不想使用条件格式。我已经这样做了。有用。人们总是想要例子，但我已经重写了很多次，这是我尝试过的最后两个：

同样，我的范围是 x.Range("A4:R380")。寻找如何识别整个重复行；不基于单个列或值等。一行中的所有列。任何帮助表示赞赏。这更像是一次学习经历。Office 2010 和 Office 2011 (Mac)

    Set rngCl = mySheet.Range("A4:R" + CStr(LastRd))
    Set wf = Application.WorksheetFunction

        For i = 4 To LastRd
        Set cl = rngCl.Rows(i).EntireRow
            If wf.CountIf(rngCl, cl.Value) > 1 Then
            MsgBox "found"
                With cl.Interior
                    .Pattern = xlSolid
                    .PatternThemeColor = xlThemeColorAccent1
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0.799981688894314
                End With
                With cl.Font
                    .Color = -16776961
                    .TintAndShade = 0
                    .Bold = True
                End With
            End If
        Next i

    End Sub



    Sub DuplicateValue()
        Dim Values As Range, iX As Integer
         'set ranges (change the worksheets and ranges to cover where the staterooms are entered
        Set Values = Sheet6.Range("A4:R389")
         con = 0
         con1 = 0
         'checking on first worksheet
        For iX = Values.Rows.Count To 1 Step -1
            If WorksheetFunction.CountIf(Values, Cells(iX, 1).Value) > 1 Then
                con = con + 1
                'MsgBox "Stateroom " & Cells(iX, 1).Address & " has already been issued an iPad!!", vbCritical
                'Cells(iX, 1).ClearContents
            End If
            If WorksheetFunction.CountIf(Values, Cells(iX, 3).Value) > 1 Then
                con1 = con1 + 1
                'MsgBox "This iPAD has already been issued!!", vbCritical
                'Cells(iX, 3).ClearContents
            End If
        Next iX

        MsgBox CStr(con) + ":" + CStr(con1)
    End Sub
4

1 回答 1

1

晨练不错！;-)

这是我想出的：

Option Explicit

Sub HighlightDuplicates()
    Dim colRowCount As Object

    Dim lo As ListObject
    Dim objListRow As ListRow, rngRow As Range
    Dim strSummary As String

    Set colRowCount = CreateObject("Scripting.Dictionary")

    Set lo = Sheet1.ListObjects(1)

    'Count occurrence of unique rows
    For Each objListRow In lo.ListRows
        strSummary = GetSummary(objListRow.Range)
        colRowCount(strSummary) = colRowCount(strSummary) + 1
    Next

    'Color code rows
    For Each objListRow In lo.ListRows
        Set rngRow = objListRow.Range            
        If colRowCout(GetSummary(rngRow)) > 1 Then
            rngRow.Interior.Color = RGB(255, 0, 0)
        Else
            rngRow.Interior.ColorIndex = RGB(0, 0, 0)
        End If
    Next

End Sub

Function GetSummary(rngRow As Range) As String
    GetSummary = Join(Application.Transpose(Application.Transpose( _
        rngRow.Value)), vbNullChar)
End Function

这会将每个唯一行的计数存储在字典中 - 如果计数大于 1，则检查每一行。

可能可以进一步优化（例如，通过将摘要字符串存储在数组中），但应该是一个好的开始。

于 2013-10-30T07:53:27.470 回答