2

私はvbaを使用しており、「Do Not Call」という名前の2つのシートがあり、列Aに約800,000行のデータがあります。このデータを使用して、「Sheet1」という名前の2番目のシートの列Iを確認したいと思います。一致が見つかった場合は、「Sheet1」の行全体を削除してください。ここで同様の質問から見つけたコードを調整しました: Excel formula to Cross reference 2 sheets, remove duplicates from one sheet and run it but何も起こりません。エラーは発生していませんが、機能していません。

ここに私が現在試しているコードがあり、なぜそれが機能しないのか分かりません

Option Explicit
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String

Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
Dim strValueA As String


keyColA = "A"
keyColB = "I"

intRowCounterA = 1
intRowCounterB = 1

Set wsA = Worksheets("Do Not Call")
Set wsB = Worksheets("Sheet1")

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    strValueA = rngA.Value
    If Not dict.Exists(strValueA) Then
        dict.Add strValueA, 1
    End If
    intRowCounterA = intRowCounterA + 1
Loop

intRowCounterB = 1
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
    Set rngB = wsB.Range(keyColB & intRowCounterB)
    If dict.Exists(rngB.Value) Then
         wsB.Rows(intRowCounterB).delete
         intRowCounterB = intRowCounterB - 1
    End If
    intRowCounterB = intRowCounterB + 1
Loop
End Sub

上記のコードがコードタグにない場合は申し訳ありません。コードをオンラインで投稿するのはこれが初めてで、正しく投稿したかどうかわかりません。

4

2 に答える 2

4

あなたが共有したコードが私を混乱させたことを認めるのは恥ずかしいです...とにかく、練習のために、シートの値をループする代わりに配列を使用して書き直しました：

Option Explicit
Sub CleanDupes()
    Dim targetArray, searchArray
    Dim targetRange As Range
    Dim x As Long

    'Update these 4 lines if your target and search ranges change
    Dim TargetSheetName As String: TargetSheetName = "Sheet1"
    Dim TargetSheetColumn As String: TargetSheetColumn = "I"
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call"
    Dim SearchSheetColumn As String: SearchSheetColumn = "A"

    'Load target array
    With Sheets(TargetSheetName)
        Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
                .Range(TargetSheetColumn & Rows.Count).End(xlUp))
        targetArray = targetRange
    End With
    'Load Search Array
    With Sheets(SearchSheetName)
        searchArray = .Range(.Range(SearchSheetColumn & "1"), _
                .Range(SearchSheetColumn & Rows.Count).End(xlUp))
    End With


    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    'Populate dictionary from search array
    If IsArray(searchArray) Then
        For x = 1 To UBound(searchArray)
            If Not dict.exists(searchArray(x, 1)) Then
                dict.Add searchArray(x, 1), 1
            End If
        Next
    Else
        If Not dict.exists(searchArray) Then
            dict.Add searchArray, 1
        End If
    End If

    'Delete rows with values found in dictionary
    If IsArray(targetArray) Then
        'Step backwards to avoid deleting the wrong rows.
        For x = UBound(targetArray) To 1 Step -1
            If dict.exists(targetArray(x, 1)) Then
                targetRange.Cells(x).EntireRow.Delete
            End If
        Next
    Else
        If dict.exists(targetArray) Then
            targetRange.EntireRow.Delete
        End If
    End If
End Sub

編集：気になったので、提供されたコードを読み直しました。文字列値のみをチェックしない限り、期待どおりに記述されておらず、失敗するため、混乱します。このスニペットで何をしているのかを示すコメントを追加しました。

'Checks to see if the particular cell is empty.
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
    'Stores the cell to a range for no good reason.
    Set rngA = wsA.Range(keyColA & intRowCounterA)
    'Converts the value of the cell to a string because strValueA is a string.
    strValueA = rngA.Value
    'Checks to see if the string is in the dictionary.
    If Not dict.Exists(strValueA) Then
        'Adds the string to the dictionary.
        dict.Add strValueA, 1
    End If

じゃあ後で：

 'checks the value, not the value converted to a string.
 If dict.Exists(rngB.Value) Then

これは、スクリプト ディクショナリが、double が文字列に変換された場合に同じになるとしても、double を文字列と同等と見なさないため、失敗します。

投稿したコードを修正する 2 つの方法は、先ほど示した行を次のように変更することです。

If dict.Exists(cstr(rngB.Value)) Then

Dim strValueA As Stringまたは、に変更できますDim strValueA。

于 2012-12-02T01:55:30.230 に答える
0

時間があったので、Dictionary を使用せずにワークシート関数を使用して書き直します。（Vlookupコメントに触発されました）。どちらが速いかわかりません。

Sub CleanDupes()
    Dim targetRange As Range, searchRange As Range
    Dim targetArray
    Dim x As Long
    'Update these 4 lines if your target and search ranges change
    Dim TargetSheetName As String: TargetSheetName = "Sheet1"
    Dim TargetSheetColumn As String: TargetSheetColumn = "I"
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call"
    Dim SearchSheetColumn As String: SearchSheetColumn = "A"

    'Load target array
    With Sheets(TargetSheetName)
        Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
                .Range(TargetSheetColumn & Rows.Count).End(xlUp))
        targetArray = targetRange
    End With
    'Get Search Range
    With Sheets(SearchSheetName)
        Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
                .Range(SearchSheetColumn & Rows.Count).End(xlUp))
    End With
    If IsArray(targetArray) Then
        For x = UBound(targetArray) To 1 Step -1
            If Application.WorksheetFunction.CountIf(searchRange, _
                                        targetArray(x, 1)) Then
                targetRange.Cells(x).EntireRow.Delete
            End If
        Next
    Else
        If Application.WorksheetFunction.CountIf(searchRange, targetArray) Then
            targetRange.EntireRow.Delete
        End If
    End If
End Sub
于 2012-12-02T05:00:00.590 に答える