根据A列第2部分中的匹配索引替换C列中的字符串

Question

使用以下代码（source）我能够执行以下操作：

1. 检查Sheet1！A中的字符串是否在Sheet2！A。
中
2. 如果找到，请比较C列值。
   • 如果C列值不同，请将Sheet2的值设置为Sheet1中的值，并突出显示浅绿色。
   • 否则，退出。
3. 如果未找到，请将整行复制到Sheet2并突出显示深绿色。

我还想执行其他一些我无法实施的步骤。

If string in Sheet2!A does not exist in Sheet1!A then highlight red.

代码在这里：

Sub LoopMatchReplace()

Dim ShSrc As Worksheet, ShTar As Worksheet
Dim SrcLRow As Long, TarLRow As Long, NextEmptyRow As Long
Dim RefList As Range, TarList As Range, RefCell As Range, RefColC
Dim TarCell As Range, TarColC As Range
Dim IsFound As Boolean
Dim ToFind As String

With ThisWorkbook
    Set ShSrc = .Sheets("Sheet1")
    Set ShTar = .Sheets("Sheet2")
End With

'Get the last rows for each sheet.
SrcLRow = ShSrc.Range("A" & Rows.Count).End(xlUp).Row
TarLRow = ShTar.Range("A" & Rows.Count).End(xlUp).Row

'Set the lists to compare.
Set RefList = ShSrc.Range("A2:A" & SrcLRow)
Set TarList = ShTar.Range("A2:A" & TarLRow)

'Initialize boolean, just for kicks.
IsFound = False

'Speed up the process.
Application.ScreenUpdating = False

'Create the loop.
For Each RefCell In RefList

    ToFind = RefCell.Value

    'Look for the value in our target column.
    On Error Resume Next
    Set TarCell = TarList.Find(ToFind)
    If Not TarCell Is Nothing Then IsFound = True
    On Error GoTo 0

    'If value exists in target column...
    If IsFound Then
        'Compare the Column C of both sheets.
        Set TarColC = TarCell.Offset(0, 2)
        Set RefColC = RefCell.Offset(0, 2)
        'If they are different, set the value to match and highlight.
        If TarColC.Value <> RefColC.Value Then
            TarColC.Value = RefColC.Value
            TarColC.Interior.ColorIndex = 4
        End If
    Else 'If value does not exist...
        'Get next empty row, copy the whole row from source sheet, and highlight.
        NextEmptyRow = ShTar.Range("A" & Rows.Count).End(xlUp).Row + 1
        RefCell.EntireRow.Copy ShTar.Rows(NextEmptyRow)
        ShTar.Rows(NextEmptyRow).SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 3
    End If

    'Set boolean check to False.
    IsFound = False

Next RefCell

Application.ScreenUpdating = True

End Sub

Answer 1

修改

试试这段代码。最后又增加了逆转。没有解释，因为它与前面的代码块类似。

Sub LoopMatchReplace()

    Dim ShSrc As Worksheet, ShTar As Worksheet
    Dim SrcLRow As Long, TarLRow As Long, NextEmptyRow As Long
    Dim RefList As Range, TarList As Range, RefCell As Range, RefColC As Range
    Dim TarCell As Range, TarColC As Range
    Dim IsFound As Boolean, IsFoundReverse As Boolean
    Dim ToFind As String, ToFindReverse As String
    Dim TarListReverse As Range, TarCellReverse As Range
    Dim RefListReverse As Range, RefCellReverse As Range

    With ThisWorkbook
        Set ShSrc = .Sheets("Sheet1")
        Set ShTar = .Sheets("Sheet2")
    End With

    'Get the last rows for each sheet.
    SrcLRow = ShSrc.Range("A" & Rows.Count).End(xlUp).Row
    TarLRow = ShTar.Range("A" & Rows.Count).End(xlUp).Row

    'Set the lists to compare.
    Set RefList = ShSrc.Range("A2:A" & SrcLRow)
    Set TarList = ShTar.Range("A2:A" & TarLRow)

    'Initialize boolean, just for kicks.
    IsFound = False

    'Speed up the process.
    Application.ScreenUpdating = False

    'Create the loop.
    For Each RefCell In RefList

        ToFind = RefCell.Value

        'Look for the value in our target column.
        On Error Resume Next
        Set TarCell = TarList.Find(ToFind)
        If Not TarCell Is Nothing Then IsFound = True
        On Error GoTo 0

        'If value exists in target column...
        If IsFound Then
            'Compare the Column C of both sheets.
            Set TarColC = TarCell.Offset(0, 2)
            Set RefColC = RefCell.Offset(0, 2)
            'If they are different, set the value to match and highlight.
            If TarColC.Value <> RefColC.Value Then
                TarColC.Value = RefColC.Value
                TarColC.Interior.ColorIndex = 4
            End If
        Else 'If value does not exist...
            'Get next empty row, copy the whole row from source sheet, and highlight.
            NextEmptyRow = ShTar.Range("A" & Rows.Count).End(xlUp).Row + 1
            RefCell.EntireRow.Copy ShTar.Rows(NextEmptyRow)
            ShTar.Rows(NextEmptyRow).SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 3
        End If

        'Set boolean check to False.
        IsFound = False

    Next RefCell

    'Reverse checking of names.
    IsFoundReverse = False
    SrcLRow = ShSrc.Range("A" & Rows.Count).End(xlUp).Row
    TarLRow = ShTar.Range("A" & Rows.Count).End(xlUp).Row
    Set TarListReverse = ShTar.Range("A2:A" & TarLRow)
    Set RefListReverse = ShSrc.Range("A2:A" & SrcLRow)

    For Each TarCellReverse In TarListReverse

        ToFindReverse = TarCellReverse.Value
        On Error Resume Next
        Set RefCellReverse = RefListReverse.Find(ToFindReverse)
        If Not RefCellReverse Is Nothing Then IsFoundReverse = True
        On Error GoTo 0

        If IsFoundReverse Then
            'Do nothing and move on.
        Else
            TarCellReverse.EntireRow.SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 3
        End If

        IsFoundReverse = False

    Next TarCellReverse

    Application.ScreenUpdating = True

End Sub

可以在 here 找到视频演示。

如果有帮助，请告诉我们。