首页 文章

宏匹配来自sheet1的字符串值，如果匹配则将下一个单元格值复制到sheet2

提问于
浏览 次
-1

我需要找到sheet2（C：C）中sheet1的每个单元格（C：C）值的匹配，如果值匹配，则复制相应的下一个单元格，即D：D并替换为表格2.如果不匹配然后将范围A复制并粘贴到工作表2中下一个空单元格中

Sub Method1()
    Dim strSearch As String
    Dim strOut As String
    Dim bFailed As Boolean
    Dim i As Integer

    strSearch = Sheet1.Range("C2")
    i = 1
    Do Until ActiveCell.Value = Empty
    ActiveCell.Offset(1, 0).Select 'move down 1 row
    i = i + 1 'keep a count of the ID for later use
    Loop
    'ActiveCell.Value = i

    On Error Resume Next
    strOut = Application.WorksheetFunction.VLookup(strSearch, Sheet2.Range("C:C"), 2, False) 
            If Err.Number <> 0 Then bFailed = True
    On Error GoTo 0

    If Not bFailed Then
    MsgBox "corresponding value is " & vbNewLine & strOut
    Else
    MsgBox strSearch & " not found"
    End If
    End Sub

Sheet1：`在这里输入代码
enter image description here

Sheet2：
enter image description here

excel vba excel-vba

2 回答

  • 0

    但是，我对我的代码进行了更改并完成了工作，但是我想在C：C中重复每个单元格的功能，看一看

    Sub Method1()
                            Dim strSearch As String
                            Dim strOut As String
                            Dim bFailed As Boolean
                            Dim i As Integer

                            strSearch = Sheet1.Range("C2")
                            i = 1
                            'Do Until ActiveCell.Value = Empty
                                     ActiveCell.Offset(1, 0).Select 'move down 1 row
                                     i = i + 1 'keep a count of the ID for later use
                                ' Loop

                             'ActiveCell.Value = i

                            On Error Resume Next
                            strOut = Application.WorksheetFunction.VLookup(strSearch, Sheet2.Range("C:C"), 1, False)
                            If Err.Number <> 0 Then bFailed = True
                            On Error GoTo 0

                            If Not bFailed Then
                            Worksheets("Sheet1").Range("e2").Copy
                            Worksheets("Sheet2").Range("e2").PasteSpecial Paste:=xlPasteFormulas
                            Application.CutCopyMode = False
                            ActiveCell.Interior.ColorIndex = 6
                            MsgBox "corresponding value been copied " & vbNewLine & strOut
                            Else

                            MsgBox strSearch & " not found"
                            End If
                            End Sub
    回复于
  • 0

    试试这个：

    Sub Method1()

    Dim cSearch As Range, m

    Set cSearch = Sheet1.Range("C2")

    Do While Len(cSearch.Value) > 0
        'omit the "WorksheetFunction" or this will throw a run-time error
        '   if there's no match. Instead we check the return value for an error
        m = Application.Match(cSearch.Value, Sheet2.Range("C:C"), 0)

        If Not IsError(m) Then
            'got a match - update ColD on sheet2
            Sheet2.Cells(m, "D").Value = cSearch.Offset(0, 1).Value
        Else
            'no match - add row to sheet2 (edit)
            cSearch.Offset(0, -2).Resize(1, 4).Copy _
                     Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If

        Set cSearch = cSearch.Offset(1, 0) 'next value to look up
    Loop

End Sub
    回复于

相关问题