0

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

我检查了问题重复项，但尚未找到与语言+主题焦点/细节完全匹配的内容。这个stackoverflow问题似乎有相似之处，但我觉得不一样：需要找到一种方法让这个宏循环遍历所有其他列

我已经检查了 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 列 AZ、第 2 列 AZ 和第 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': Object variable or With block variable not set ”。

第 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 永远不会执行。

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

非常感谢，

杰克橙灯笼

4

1 回答 1

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
于 2012-07-23T21:20:28.013 回答