vba Excel根据另一个工作表中的列表内容查找和替换单元格内容

Excel find & replace cell contents based on contents of a list in another sheet

提问by CamSpy

Possible Duplicate:
Excel clear cells based on contents of a list in another sheet

可能的重复：
Excel 根据另一个工作表中的列表内容清除单元格

On Excel clear cells based on contents of a list in another sheetbonCodigo helped me with a VBA macro script that has column and row ranges specified to take the words from A column of Sheet1, then find them as an exact match in Sheet2 columns to get found ones cleaned. Results get generated in Sheet3.

在Excel 上，根据另一个工作表中列表的内容清除单元格，bonCodigo 帮助我使用了一个 VBA 宏脚本，该脚本具有指定的列和行范围以从 Sheet1 的 A 列中获取单词，然后在 Sheet2 列中找到它们作为完全匹配来获得发现清理干净了。结果在 Sheet3 中生成。

This is the VBA code that does that:

这是执行此操作的 VBA 代码：

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("A1:A38").Value)
'-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
arrData = WorksheetFunction.Transpose(Sheets(2).Range("A1:I100").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(3).Range("A1").Offset(0, 0).Resize(UBound(arrData, 2), _
UBound(arrData)) = Application.Transpose(arrData)

End Sub

This time I need help with a slightly different VBA. In Sheet1 B columnt here is another list of words, so the VBA should not find and clear the cells contents matching wordlist values found on Sheet1 A column, but replace the found values (exact match is needed) with the ones from Sheet1 B column.

这次我需要一个稍微不同的 VBA 的帮助。在 Sheet1 B columnt 中，这里是另一个单词列表，因此 VBA 不应查找和清除与 Sheet1 A 列上找到的单词列表值匹配的单元格内容，而是将找到的值（需要完全匹配）替换为来自 Sheet1 B 列的值。

回答by Peter L.

If I understood the input correctly, the below code will find "ac" from Sheet1!A1and replace it to "hertha" from Sheet1!B1:

如果我正确理解输入，下面的代码将找到“ac”Sheet1!A1并将其替换为“hertha” Sheet1!B1：

Sub MatchAndReplace()
    Dim ws As Worksheet
    Dim arrKeysA As Variant, arrKeysB As Variant, arrData As Variant
    Dim i As Integer, j As Integer, k As Integer

    '-- here we take keys column A from Sheet 1 into a 1D array
    arrKeysA = WorksheetFunction.Transpose(Sheets(1).Range("A1:A38").Value)
    '-- here we take keys column B from Sheet 1 into a 1D array
    arrKeysB = WorksheetFunction.Transpose(Sheets(1).Range("B1:B38").Value)
    '-- here we take to be replaced range from Sheet 2 into a 2D array
    arrData = WorksheetFunction.Transpose(Sheets(2).Range("A1:I100").Value)

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

    '-- put new data on the sheet 3
    Sheets(3).Range("A1").Offset(0, 0).Resize(UBound(arrData, 2), _
    UBound(arrData)) = Application.Transpose(arrData)

End Sub

Here is the resulting Excel book with macro results on Sheet3: https://www.dropbox.com/s/i8ya0u7j6tjee13/MatchAndReplace.xls

这是在 Sheet3 上带有宏结果的 Excel 工作簿：https: //www.dropbox.com/s/i8ya0u7j6tjee13/MatchAndReplace.xls

Please respond in case something is not as expected.

如果出现不符合预期的情况，请回复。