0

これがどれほど困難だったか信じられません。重複する行をすべて見つけたい。列 A:R、動的な行数。行を削除する方法を知っています。しかし、私はそれらを強調したいだけです。それが役立つ場合、私のデータはリストオブジェクト（テーブル）にあります。いいえ！条件付き書式を使用したくありません。私はすでにそれをしました。できます。人々は常に例を求めていますが、私はこれを何度も書き直しました。ここに私が試した最後の2つがあります:

繰り返しますが、範囲は 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 に答える