1

A1からT1までの1000行と20列のExcel Sheet1があります。その範囲内の各セルには、通常 1 つまたは 2 つの単語が含まれています。Sheet2のA1列には、1000個の値のデータのリストがあります。

Sheet1のSheet2リストから単語を検索し、見つかったセルの値をクリアするVBAスクリプトに取り組んでいます。

Sheet1のA1列でのみ機能するVBAスクリプトがあり、行のみを削除します。スクリプトは次のとおりです。

Sub DeleteEmails() 
Dim rList As Range 
Dim rCrit As Range 

With Worksheets("Sheet1") 
    .Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header" 
    Set rList = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) 
End With 
With Worksheets("Sheet2") 
    .Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header" 
    Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) 
End With 

rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False 
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp 
Worksheets("Sheet1").ShowAllData 

rList(1).Delete shift:=xlUp: rCrit(1).Delete shift:=xlUp 

Set rList = Nothing: Set rCrit = Nothing 
End Sub

誰でも私を助けることができますか？行を削除するのではなく、値をクリアする必要があります。これは、A1 だけでなく、シート 1 のすべての列で機能するはずです。

4

2 に答える 2

2

シート (範囲/セルを介した反復) とコード間のトラフィックを最小限に抑えることにより、配列を使用する別の方法を次に示します。このコードではclear contents. 範囲全体を配列に取り、それをクリーンアップして、必要なものを入力するだけです:)ボタンをクリックするだけです。

  • OP の要求に従って編集: コメントを追加し、目的のシートのコードを変更します。

コード：

Option Explicit

Sub matchAndClear()
    Dim ws As Worksheet
    Dim arrKeys As Variant, arrData As Variant
    Dim i As Integer, j As Integer, k As Integer

    '-- here we take keys column from Sheet 1 into a 1D array
    arrKeys = WorksheetFunction.Transpose(Sheets(1).Range("A2:A11").Value)
    '-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
    arrData = WorksheetFunction.Transpose(Sheets(2).Range("C2:D6").Value)

    '-- here we iterate through each key in keys array searching it in 
    '-- to-be-cleaned-up array
    For i = LBound(arrKeys) To UBound(arrKeys)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(1, j) = " "
                End If
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(2, j) = " "
                End If
        Next j
    Next i

    '-- replace old data with new data in the sheet 2 :)
    Sheets(2).Range("C2").Offset(0, 0).Resize(UBound(arrData, 2), _
    UBound(arrData)) = Application.Transpose(arrData)

End Sub

  • ここで本当に設定する必要があるのは範囲であることに注意してください。

    1. キー範囲
    2. クリーンアップ範囲

出力: (表示目的で同じシートを使用していますが、必要に応じてシート名を変更できます。

ここに画像の説明を入力

OPのファイルを実行するためのOPの要求に基づいて編集します。

すべての列をクリーニングしなかった理由は、上記のサンプルでは 16 列あるのに 2 つの列のみをクリーニングしているためです。forそのため、それを繰り返すために別のループを追加する必要があります。パフォーマンスの大幅な低下はありませんが、少し ;) 以下は、送信したシートを実行した後のスクリーンショットです。それ以外に変更するものは何もありません。

コード：

'-- here we iterate through each key in keys array searching it in
    '-- to-be-cleaned-up array
    For i = LBound(arrKeys) To UBound(arrKeys)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
            For k = LBound(arrData) To UBound(arrData)
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(k, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(k, j) = " "
                End If
            Next k
        Next j
    Next i
于 2013-01-14T19:24:44.647 に答える
2

私は今手元にエクセルを持っていないので、これは数式名で正確に 100% 正確ではないかもしれませんが、この行を変更する必要があると思います:

rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp

に

rList.Offset(1).ClearContents

rList を目的の選択に設定したら、Delete行を削除してクリアしない理由です。範囲全体ではなく、のみ(1)を行っていた理由です。A1

編集

私がこれをテストした最終的なコードは次のとおりです（現在、すべての列を調べています）：

Option Explicit

Sub DeleteEmails()
    Dim rList As Range
    Dim rCrit As Range
    Dim rCells As Range
    Dim i As Integer

    With Worksheets("Sheet2")
        .Range("A1").Insert shift:=xlDown
        .Range("A1").Value = "Temp Header"
        Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
    End With

    Set rCells = Sheet1.Range("$A$1:$T$1")

    rCells.Insert shift:=xlDown

    Set rCells = rCells.Offset(-1)

    rCells.Value = "Temp Header"

    For i = 1 To rCells.Count
        Set rList = Sheet1.Range(rCells(1, i).address, Sheet1.Cells(Rows.Count, i).End(xlUp))

        If rList.Count > 1 Then  'if a column is empty as is in my test case, continue to next column
            rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
            rList.Offset(1).ClearContents
            Worksheets("Sheet1").ShowAllData
        End If
    Next i

    rCells.Delete shift:=xlUp
    rCrit(1).Delete shift:=xlUp

    Set rList = Nothing: Set rCrit = Nothing

End Sub

PS: vba で「:」を使用しないでください。vba のデフォルトの IDE で気付くのは非常に難しく、理由を理解するのにしばらく時間がかかりましたが、意味がありません!

于 2013-01-13T11:25:06.333 に答える