从另一张纸自动完成

Question

我正在尝试自动填充以在第二列上工作

我有一些代码可以自动完成从源工作表列A到另一个工作表列C的工作，我需要复制该代码以自动完成同一源工作表中第二列的第二列（从B列到D列）。

Private Sub Worksheet_Change(ByVal Target As Range)
     'Sub "autocompletes" data entered into column C using a source table on a different worksheet. If more than one match is
     '    found, the user is allowed to continue entering characters until a unique match is found. If no matches are found, the
     '    data is accepted as entered. ALT + Enter, Enter to force the macro to accept data as entered. The sub is triggered by
     '    the Enter key.
    Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range

     '***Please adjust the next two statements before using this code!***
    Set targ = Intersect(Target, Range("C:C")) 'Watch the cells in column C
    Set rg = Worksheets("Client list").Range("A:A") 'Use named range AutoCompleteText for "autocomplete" info

    If targ Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo errhandler 'If code encounters an error, turn events back on

    For Each cel In targ
        If Not IsError(cel) Then
            If cel <> "" And Right(cel, 1) <> Chr(10) Then
                Set match1 = Nothing
                Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False) 'Match is case insensitive
                If Not match1 Is Nothing Then
                    Set match2 = rg.FindNext(after:=match1)
                    If match2.Address = match1.Address Then 'Code is fooled by identical strings in two cells
                        cel = match1 'Only one match found. Use it to "autocomplete" the cell
                    Else 'More than one match found. User must enter more data. Return to "Edit" mode
                        cel.Activate
                        Application.SendKeys ("{F2}") 'Begin editing after last character entered
                    End If
                Else 'No matches found. Do not change entered text
                End If
            Else 'Strip the line feed from the end of the text string
                If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
            End If
        End If
    Next cel


errhandler:     Application.EnableEvents = True

    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

Answer 1

我认为可能有一种更简单或更快速的方法进行操作，但是对于您当前的代码，您可以按照以下方式进行操作：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range


For i = 1 to 2

If i = 1 then
    Set targ = Intersect(Target, Range("C:C"))
    Set rg = Worksheets("Client list").Range("A:A")
Elseif i = 2 then
   Set targ = Intersect(Target,Range(“D:D”))
   Set rg = Worksheets(“Client list”).Range(“B:B”)
End If

    If targ Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo errhandler 'If code encounters an error, turn events back on

    For Each cel In targ
        If Not IsError(cel) Then
            If cel <> "" And Right(cel, 1) <> Chr(10) Then
                Set match1 = Nothing
                Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False) 'Match is case insensitive
                If Not match1 Is Nothing Then
                    Set match2 = rg.FindNext(after:=match1)
                    If match2.Address = match1.Address Then 'Code is fooled by identical strings in two cells
                        cel = match1 'Only one match found. Use it to "autocomplete" the cell
                    Else 'More than one match found. User must enter more data. Return to "Edit" mode
                        cel.Activate
                        Application.SendKeys ("{F2}") 'Begin editing after last character entered
                    End If
                Else 'No matches found. Do not change entered text
                End If
            Else 'Strip the line feed from the end of the text string
                If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
            End If
        End If
    Next cel

  Next  
errhandler:     Application.EnableEvents = True

    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub