VBA 使用具有 .find 和 .copy 值的循环

Question

我想在我的 SearchFunction 中使用一个循环来搜索客户，直到找到合适的客户。我正在使用自定义消息框来定义找到的客户是否是我正在寻找的客户。

基本上我想要这个：

MsgBox "Is this the customer you were looking for?"

Yes: it will copy cells(sheet2) and paste them into the invoice (sheet1)
No:  it will find next customer (and ask same question)**

** And keep doing/asking this till last found customer is shown.

这是找到客户后消息框的样子： Custom msgbox

目前它搜索客户并将其显示在自定义消息框中。当我说 'Yes this is the customer' 时，它会复制应有的值并将它们粘贴到发票中。但是当我说 'no this not my customer' 时，它不会转到下一个找到的客户，但会退出 SearchFunction。

我试过使用循环，但无法正常工作。我也试过 .findnext 但我无法将它嵌入到我正在使用的代码中..

这是我正在使用的代码：

Sub SearchCustomer()
 '
 ' Search for customer
 '
 '*****************************************************************************************************


Dim Finalrow As Integer
Dim I As Integer
Dim cC As Object
Dim iR As Integer
Dim foundrange As Range

 '*****************************************************************************************************
 '                                      This Searches for the customer
 '*****************************************************************************************************

' Set up searchrange
    Set foundrange = Sheets("sheet2").Cells.Find(What:=Sheets("sheet1").Range("B12").Value, LookIn:=xlFormulas, LookAt:=xlPart)

' Checks if fields are filled
If Sheets("sheet1").Range("B12").Value = "" Then
    MsgBox "Please fill in a search key", vbOKOnly, "Search customer"

Else

    'When nothing is found
    If foundrange Is Nothing Then
        MsgBox "Customer not found," & vbNewLine & vbNewLine & "Refine your search key", vbOKOnly, "Search customer"

    Else

        Finalrow = Sheets("sheet1").Range("A1000").End(xlUp).Row

        For I = 2 To Finalrow

            'When range is found
            If Worksheets("sheet2").Cells(I, 1) = foundrange Then
                Set cC = New clsMsgbox
                cC.Title = "Search contact"
                cC.Prompt = "Is this the customer you searched for?" & vbNewLine & "" & vbNewLine & Worksheets("sheet2").Cells(I, 1) & vbNewLine & Worksheets("sheet2").Cells(I, 2) _
                & vbNewLine & Worksheets("sheet2").Cells(I, 3) & vbNewLine & Worksheets("sheet2").Cells(I, 4) & vbNewLine & Worksheets("sheet2").Cells(I, 5)
                cC.Icon = Question + DefaultButton2
                cC.ButtonText1 = "Yes"
                cC.ButtonText2 = "No"
                 iR = cC.MessageBox()

                If iR = Button1 Then
                    'Name
                    Worksheets("sheet2").Cells(I, 1).Copy
                    Worksheets("sheet1").Range("B12").PasteSpecial xlPasteFormulasAndNumberFormats
                    'Adress
                    Worksheets("sheet2").Cells(I, 2).Copy
                    Worksheets("sheet1").Range("B13").PasteSpecial xlPasteFormulasAndNumberFormats
                    'Zipcode & City
                    Worksheets("sheet2").Cells(I, 3).Copy
                    Worksheets("sheet1").Range("B14").PasteSpecial xlPasteFormulasAndNumberFormats
                    'Phonenumber
                    Worksheets("sheet2").Cells(I, 4).Copy
                    Worksheets("sheet1").Range("B15").PasteSpecial xlPasteFormulasAndNumberFormats
                    'E-mail
                    Worksheets("sheet2").Cells(I, 5).Copy
                    Worksheets("sheet1").Range("B16").PasteSpecial xlPasteFormulasAndNumberFormats

                ElseIf iR = Button2 Then
                    MsgBox "Customer not found", vbOKOnly, "Contact zoeken"

                End If

                Range("B12").Select

            End If 'gevonden item
        Next I

    Application.CutCopyMode = False

    End If
End If

End Sub

有些帮助会很棒！找了好久

在此先致谢！

问候 Mikos

Answer 1

您需要重构代码，For 循环对于遍历搜索结果没有意义。您需要一个 Do While 循环，请参阅 Range.FindNext Method

中的示例

伪代码：

Set foundrange = Sheets("sheet2").Cells.Find(What:=...)
Do While Not foundrange Is Nothing
    If Msgbox(<Customer data from foundrange.Row>) = vbYes Then 
        ' copy stuff
        Exit Do  ' we're done
    Else
        Set foundrange = Sheets("sheet2").Cells.FindNext(After:=foundrange)
    End If
Loop

P.S。 这些不是您要找的机器人！

Answer 2

非常感谢Andre451，他解决了我的问题！

最终代码：

Sub SearchCustomer()
 '
 ' Search customer
 '
 '*****************************************************************************************************

    Dim Finalrow As Integer
    Dim foundrange As Range
    Dim answer As Integer

 '*****************************************************************************************************
 '                                      Search for customername
 '*****************************************************************************************************
' Search Range
Set foundrange = Sheets("sheet2").Cells.Find(What:=Sheets("sheet1").Range("B12").Value, LookIn:=xlFormulas, LookAt:=xlPart)
Finalrow = Sheets("sheet1").Range("A:A").End(xlDown).Row

' Checks if search range is filled
If Sheets("sheet1").Range("B12").Value = "" Then
    MsgBox "Please fill in a searchkey", vbOKOnly, "Search customer"
Else
    Do While Not foundrange Is Nothing
        If MsgBox("Is this the customer you were looking for? " & foundrange, vbYesNo + vbQuestion, "Zoek klant") = vbYes Then
            'Name
            foundrange.Copy
            Worksheets("sheet1").Range("B12").PasteSpecial xlPasteFormulasAndNumberFormats
            'Address
            foundrange.Offset(0, 1).Copy
            Worksheets("sheet1").Range("B13").PasteSpecial xlPasteFormulasAndNumberFormats
            'Zipcode and City
            foundrange.Offset(0, 2).Copy
            Worksheets("sheet1").Range("B14").PasteSpecial xlPasteFormulasAndNumberFormats
            'Phonenumber
            foundrange.Offset(0, 3).Copy
            Worksheets("sheet1").Range("B15").PasteSpecial xlPasteFormulasAndNumberFormats
            'Email
            foundrange.Offset(0, 4).Copy
            Worksheets("sheet1").Range("B16").PasteSpecial xlPasteFormulasAndNumberFormats
            Exit Do
        Else
            Set foundrange = Sheets("sheet2").Cells.FindNext(After:=foundrange)
            End If
Loop

Range("B12").Select
Application.CutCopyMode = False

End If
End Sub

再次感谢！

VBA 使用具有 .find 和 .copy 值的循环

VBA using Loop with .find and .copy values

vba

copy

paste