0

大量のデータを含むシート (sheet1) があります。このデータにはいくつかの列があり、そのうちの 1 つは nameColumn と呼ばれます。nameColumn には、行ごとに 1 つの単語が含まれます。

シート 2 には、600 語のリストがあります。

シート2の単語と一致するnameColumnの単語を含むシート1からすべての行を削除する必要があります

sheet1 を nameColumn でアルファベット順に並べ替え、sheet2 もアルファベット順に並べ替えました。

私が書いたコードは機能しますが、ひどいものです。シート 1 の行数に対して for ループを作成し、内部にネストされた while ループを作成します。このループは 2 つのシート間で値を比較し、nameColumn で一致が見つかった場合は行を削除します。シート1の問題の単語がシート2の単語よりもアルファベット順で「大きい」場合にのみ「i」を増やすようにwhileループに指示することで、「最適化」を試みました。

このコードは、約 10,000 行を処理するのに 20 分かかります。どうすれば速くなりますか？

一致しない行を別のシートにコピーするようにコードを変更しようとしたことに注意してください。これは単に遅いようです。この投稿Excel / VBA Remove duplicate rows by cross referencing 2 different sheets then delete 1 rowも見ましたが、率直に言って、それを実装しようとするのに十分な理解がありません。

Sub removerows3()
Application.ScreenUpdating = False

Dim numberof_data_rows As Long
numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

Dim numberof_alert_rows As Long
numberof_alert_rows = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row

Dim nameColumn As Integer
nameColumn = 3 

Dim current_alert_row As Integer
current_alert_row = 2

Dim current_data_row As Long
current_data_row = 2

Dim keep_searching_dosealert As Integer
keep_searching_dosealert = 1


For current_data_row = 2 To numberof_data_rows


Do While keep_searching_dosealert = 1
    If Sheet2.Cells(current_alert_row, 1) = Cells(current_data_row, nameColumn) 
        Cells(current_data_row, nameColumn).EntireRow.Delete
        keep_searching_dosealert = 0
        current_data_row = current_data_row - 1
        numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = 1 Then 
        keep_searching_dosealert = 0
        current_alert_row = current_alert_row - 1

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = -1 Then 
        keep_searching_dosealert = 1
        current_alert_row = current_alert_row + 1
    Else
        MsgBox ("error")

    End If
Loop
keep_searching_dosealert = 1


Next current_data_row

End Sub
4

2 に答える 2

1

次のコードのコメントを参照してください。Sheet1 の右側の列に一時的な配列式を作成します。チェックしている列の右側にある 20 列です。必要に応じて、この数を増やしてください。

Sub DeleteAcross2()
    Dim calc As Variant
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim dels As Variant
    Dim x As Long
    Dim rngDel As Range

    Application.ScreenUpdating = False
    'remember the Calculation Mode to reinstate later
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual

    Set ws1 = Worksheets("Sheet1")
    Set rng1 = ws1.Range("B2:B70")      'change this range
    Set ws2 = Worksheets("Sheet2")
    Set rng2 = ws2.Range("A1:A4")       'change this range

    'add a formula-column 20 columns to the right - increase this number if necessary
    rng1.Offset(0, 20).FormulaArray = "=ISNA(MATCH(Sheet1!$B$2:$B$70,Sheet2!$A$1:$A$4,0))"
    'creates a column of True/False values - we will delete rows with False
    dels = rng1.Offset(0, 20).Value
    For x = 1 To UBound(dels, 1)
        If dels(x, 1) = False Then
            If rngDel Is Nothing Then
                Set rngDel = rng1.Cells(x, 1)       'the first cell
            Else
                Set rngDel = Union(rngDel, rng1.Cells(x, 1))
            End If
        End If
    Next x
    rng1.Offset(0, 20).Clear        'remove the array-formula (required)
    If rngDel Is Nothing Then Exit Sub      'no matches found
    rngDel.EntireRow.Delete
    Application.Calculation = calc
    Application.ScreenUpdating = True
End Sub

実行に20分もかかりません:)

于 2013-07-14T06:56:55.520 に答える
0

一致する単語を含む Sheet1 データの行を削除する代わりに、以下のコードはデータの新しいコピーを作成し、一致する単語を含む行を除外して Sheet3 に作成します。次の手順は、Sheet1 を削除し、名前を変更して Sheet3 を移動することです (これらの手順はコードに含めていません)。

このコードは、Sheet1 の nameColumn と Sheet2 の wordColumn を VBA 配列にコピーします。nameColumn 配列をループ処理して、wordColumn 配列内の一致を検索します。照合プロセスを高速化するために、Sheet2 の単語リストは照合前に並べ替えられます。一致が見つかると、フラグ値 1 が結果配列に設定されます。

次に、結果の配列を Sheet1 に書き戻し、シート 1 のデータ範囲にオートフィルターを設定して、一致する単語を含む行を除外します。最後の手順は、フィルター処理されたデータを Sheet3 にコピーすることです。

42,000 語の nameColumn でコードをテストし、26 列のランダムな数値データを、nameColumn の単語からランダムに抽出されたソート済みの 600 語のリストと照合しました。コードの実行には約 5 秒かかり、その時間の 80% が単語一致ループに費やされました。(一致した行をその場で削除するバージョンのコードもテストしました。この変更により、実行時間が 2 倍になりました。)

Sub FilterOnNoMatchAndCopy()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastCell As Range, ws2LastCell As Range
    Dim valueArr(), searchArr(), resultArr()
    Dim i As Long, j As Long
    Dim sort_Sheet2_list As Boolean

    sort_Sheet2_list = True

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
    Set ws2 = ActiveWorkbook.Worksheets("Sheet2")

'   create Sheet3 if it doesn't exist, clear it if it does
    Set ws3 = Nothing
    On Error Resume Next
    Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    On Error GoTo 0
    If ws3 Is Nothing Then
        Worksheets.Add(After:=ws2).Name = "Sheet3"
        Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    End If
    ws3.Cells.Clear

'   Find last cell in used ranges
    With ws1
        Set ws1LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With
    With ws2
        Set ws2LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With

'   copy the nameColumn and wordColumn into VBA arrays 
'   (if nameColumn and wordColumn are not in column A, change here)     
    valueArr = ws1.Range("$A$2:$A$" & ws1LastCell.Row)
    If sort_Sheet2_list Then
        ws2.Range("$A$2:$A$" & ws2LastCell.Row).Sort Key1:=ws2.Range("A2"), _
            Order1:=xlAscending, Header:=xlNo
    End If
    searchArr = ws2.Range("$A$2:$A$" & ws2LastCell.Row)

'   create a new array that will flag which words in nameColumn are matches
    ReDim resultArr(LBound(valueArr, 1) To UBound(valueArr, 1), 1 To 1)

'  search for matches 
   For i = 1 To UBound(valueArr, 1)
        j = 1
        Do While j < (UBound(searchArr, 1) + 1)
            If valueArr(i, 1) > searchArr(j, 1) Then
                j = j + 1
            Else
                If valueArr(i, 1) = searchArr(j, 1) Then
                    resultArr(i, 1) = 1
                End If
                j = UBound(searchArr, 1) + 1
            End If
        Loop
    Next

'   write match results to Sheet1, set autofilter to exclude matches, 
'       and copy result to Sheet3
    With ws1
        .Cells(1, ws1LastCell.Column + 1).value = "found"
        .Range(.Cells(2, ws1LastCell.Column + 1), _
            .Cells(ws1LastCell.Row, ws1LastCell.Column + 1)) = _
            resultArr
        .Range("A1").AutoFilter ws1LastCell.Column + 1, "<>1"
        .Range(.Cells(1, 1), .Cells(ws1LastCell.Row, ws1LastCell.Column)).Copy Destination:=ws3.Range("A1")
        .AutoFilterMode = False
        .Cells(1, ws1LastCell.Column + 1).EntireColumn.Delete
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub
于 2013-07-15T03:30:31.327 に答える