0

特に重複などの潜在的なパターンを検索するために、メインフレーム システムから Excel マクロを介してインポートされたデータを並べ替えようとしています。言うまでもなく、マクロは正常に機能し、質問の背景として機能します。

質問の重複を確認しましたが、言語+主題の焦点/詳細と完全に一致するものはまだ見つかりません. このスタックオーバーフローの質問は似ているように見えましたが、同じではないと思います:他のすべての列でこのマクロをループする方法を見つける必要があります

AND 条件を調べましたが、正直なところ、それを使用してループを実行し、比較を実行し、Decimal 型の値ベースのペアの可能なすべての順列を見つける方法について困惑しています。

3 つの条件に基づいてデータを並べ替えています。2 つは 3 番目の前提条件として機能します。次のようになります。

[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 データの例です (ワークシートの移行後)。

カテゴリ 1ID カテゴリ 2ID の値

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

これが私の現在のソリューションセットです-

まず、ループに使用する 3 つの列にデータを並べ替えます。データは、列 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': オブジェクト変数または With ブロック変数が設定されていません」というエラーが発生します。

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 に答える