Question

我正在尝试对从大型机系统中通过excel宏导入的数据进行排序，以便搜索潜在的模式，特别是对于重复项等。可以说，宏工作正常，只是作为问题的背景。

我检查了问题重复项，但尚未找到与语言+主题焦点/细节完全匹配的内容。这个stackoverflow问题似乎有相似之处，但我觉得它不一样：Need to find a way to loop this macro through every other column

我已经检查了AND条件，但说实话我觉得难以理解如何使用它来帮助我循环，运行比较并找到所有可能的Decimal类型基于值的对的排列。

我根据三个条件对数据进行排序，其中两个作为第三个条件的先决条件，这样：

[pseudocode/thought process]
----------
IF String Comparison 1 (Cell Col 1 R 1) == (Cell Col 1 R 2) AND
IF String Comparison 2 (Cell Col 2 R 1) == (Cell Col 2 R 2) AND
IF Value of DECIMAL (Cell Col 3 R1) == DECIMAL (Cell Col 3 R2)
CHANGE CELLCOLOR to 'SomeColor'
----------
LOOP Through and run all value pair checks given String Compare 1,2 == TRUE for all 
comparisons of String Comparison 1 & String Comparison 2

我确信有一个简单的以OOP为中心的解决方案只是递归循环遍历单元格，但我没有看到它。

以下是我的示例foobar数据（后工作表迁移）：

Category1ID Category2ID值

CCC400 219S2 400

CCC400 219S2 400

BBB300 87F34 300

BBB300 87F34 300

ABA250 987M9 500

600DDD 0432QV 700

500ABA 01W29 600

200AAA 867B2 200

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

这是我目前的解决方案集 -

首先，我将数据排序到我将用于循环的三列中。数据按列1 A-Z，列2 A-Z排序，然后列3最小值到最大值：

代码块1

Sub DataCopy()
'
' DataCopy Macro
' Move some data and sort.
'

'
    Range("B:B,D:D,F:F").Select
    Range("F1").Activate
    Selection.Copy
    Sheets("Worksheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "A2:A14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "B2:B14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "C2:C14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Worksheet2").Sort
        .SetRange Range("A1:C14")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

然后我尝试循环并根据条件“标记”匹配值：

代码块2

Private Sub CommandButton1_Click()


'Trying to set variable in type RANGE and set variable alias rng.
Dim c As Range, rng

'Trying to set variable in type RANGE and set variable alias rng2.
Dim c2 As Range, rng2

'Trying to set variable in type RANGE and set variable alias rng3.
Dim c3 As Range, rng3

Dim LASTROW As Long

LASTROW = Cells(Rows.Count, 1).End(xlUp).Row

Set rng = Range("A2:A" & LASTROW)

Set rng2 = Range("B2:B" & LASTROW)

Set rng3 = Range("C2:C" & LASTROW)

    For Each c In rng

            'If category1ID cell Ax = Ax+1, Then go to next if
            If StrComp(c, c.Offset(1, 0)) = 0 Then

                'If category2ID cell Bx = Bx+1, Then go to next if
                If StrComp(c2, c2.Offset(1, 0)) = 0 Then

                    'If the value contained of cell Cx = C, Then highlight the value cell
                    If Round(c3, 2) = Round(c3.Offset(1, 0), 2) Then

                    c3.Interior.ColorIndex = 4

                    End If

                End If

            End If

    Next c

End Sub

不幸的是，代码块2导致错误“运行时错误'91'：对象变量或未设置块变量。”

第29行的错误：

If StrComp(c2, c2.Offset(1, 0)) = 0 Then

我试图通过多种方式解决此错误，但我只是增加了我旅行时的错误数量。

理论上，如果颜色标记过程起作用，我会尝试在同一个执行按钮中执行这段代码。此代码与代码块1非常相似，不同之处在于它只是按值列（第3列）中的彩色单元格进行排序，然后按第1列AZ，第2列AZ和第3列中最小到最大值的条件进行排序：

代码块3

Sub ColorSort()
'
' ColorSort Macro
' Sorts by Color and then by various data criteria.
'

'
    Columns("A:C").Select
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add(Range("C2:C14"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 255 _
        , 0)
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "A2:A14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "B2:B14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "C2:C14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Worksheet3").Sort
        .SetRange Range("A1:C14")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

但是，由于运行时91错误，代码块3从未执行。

我希望有一个优雅的递归/迭代方法或一组方法来修复错误并优化性能，但是如果可能/可行的话，任何修复都可以。

非常感谢，

JackOrangeLantern

Answer 1

如果我理解你的逻辑，这应该有效：

Private Sub CommandButton1_Click()
    Dim c As Range, rng As Range
    Dim c2 As Range
    Dim c3 As Range
    Dim LASTROW As Long


    With ActiveSheet       
        LASTROW = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:A" & LASTROW)
    End With

    For Each c In rng.Cells

        Set c2 = c.Offset(0, 1)
        Set c3 = c.Offset(0, 2)

        If StrComp(c.Value, c.Offset(1, 0).Value) = 0 Then
            If StrComp(c2.Value, c2.Offset(1, 0).Value) = 0 Then
                If Round(c3.Value, 2) = Round(c3.Offset(1, 0).Value, 2) Then
                    'EDIT: highlight the original and the duplicate
                    c3.Resize(2,1).Interior.ColorIndex = 4
                End If
            End If
        End If
    Next c
End Sub

编辑：这应该更好（也适用于未排序的数据）

Private Sub HighlightDups()

    Const CLR_HILITE As Integer = 4
    Dim rw As Range, rng As Range
    Dim LASTROW As Long, r As Long
    Dim dict As Object, tmp

    With ActiveSheet
        LASTROW = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:C" & LASTROW)
    End With

    Set dict = CreateObject("scripting.dictionary")

    For Each rw In rng.Rows

        tmp = rw.Cells(1).Value & "~~" & rw.Cells(2).Value & _
               "~~" & CStr(Round(rw.Cells(3).Value, 1))

        If Not dict.exists(tmp) Then
            dict.Add tmp, rw.Cells(3)
        Else
            If Not dict(tmp) Is Nothing Then
                dict(tmp).Interior.ColorIndex = CLR_HILITE
                Set dict(tmp) = Nothing
            End If
            rw.Cells(3).Interior.ColorIndex = CLR_HILITE
        End If
    Next rw
End Sub

使用条件和嵌套的If-Then语句查找数值对 - VBA Excel 2007

代码块1

代码块2

代码块3

1 个答案: