在某些VBA程序中使用.find

Question

I've made a invoice form and customers 'database' so I can easily make an invoice for my customers. I'm working with 2 sheets. Sheet 1 contains the invoice form and has a "find contact" macrobutton that locates the customers information by name (given in range"B12"). When the name is found in sheet 2 it automaticly copy's the information into sheet 1.

Only thing is, I have to search for the exact and entire name otherwise it won't find it. If my contact is saved as "Nicolas Cage" it can't be found as "nicolas". So I want to know if I can integrate the next code...

.Find(What:="", , LookIn:=xlValues, LookAt:=xlPart)

(Or something which can be used to make it work.)

...in this code which I use to find the information and copy it from sheet2 to sheet1:

Option Explicit

Sub ContactOproepen()

Dim customername As String
Dim Finalrow As Integer
Dim i As Integer

customername = Sheets("Sheet1").Range("B12").Value
Finalrow = Sheets("Sheet1").Range("A1000").End(xlUp).Row

For i = 2 To Finalrow
    If Worksheets("Sheet2").Cells(i, 1) = customername 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
        'Postal & 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
    End If

Next i

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

If Range("B15") = "" Then
     MsgBox "customer not found.", vbOKOnly, "Search customer"

End If


End Sub

It would be great if it had a msgbox which asks 'is this the customer you searched for?' If it's NO it will go to the next customer till the right one is found. And if (eventually) it's YES it will proceed to copy everything and fill in the form.

I've been struggling for days now and can't find anything that will work. If you can help me that would be great!

Answer 1

You could try this:

Dim rngFound As Range
Dim bNotTheGoodOne as Boolean

'first search
Set rngFound = Sheets("Sheet2").Columns(1).Cells.Find(What:=customername, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

If rngFound Is Nothing Then
    MsgBox "No customer found", vbOKOnly
Else
    'store first found address to avoid endless loop
    FirstFound = rngFound.Address(False, False)
    Do
        'ask if it's the wanted customer
        bNotTheGoodOne = MsgBox("Customer found: " & rngFound.Cells(1,1).Value & " . Find next ?", vbOKCancel)
        If Not bNotTheGoodOne then
            Worksheets("Sheet1").Range("B12").value = rngFound.Cells(1,1).Value
            Worksheets("Sheet1").Range("B13").value = rngFound.Cells(1,1).offset(0,1).Value
        Else
            'if not, find next match
            Set rngFound = wsSearch.Cells.FindNext(rngFound)
        End if
    Loop While Not rngFound Is Nothing And rngFound.Address(False, False) <> FirstFound
End If

Answer 2

I have found the solution! Added:

Dim foundrange As Range

'
Set foundrange = Sheets("Sheet2").Cells.Find(What:=Sheets("Sheet1").Range("B12").Value, LookIn:=xlFormulas, lookat:=xlPart)

So the code becomes:

Sub ContactOproepen()
'
Dim Finalrow As Integer
Dim i As Integer
Dim cC As Object
Dim iR As Integer
Dim foundrange As Range

'
Set foundrange = Sheets("Sheet2").Cells.Find(What:=Sheets("Sheet1").Range("B12").Value, LookIn:=xlFormulas, lookat:=xlPart)


If Sheets("Sheet1").Range("B12").Value = "" Then
    MsgBox "Fill in a name please", vbOKOnly, "Search customer"

Else
If foundrange Is Nothing Then
    MsgBox "      Customer not found," & vbNewLine & vbNewLine & "       Try another searchkey.", vbOKOnly, "Search contact"

Else

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

        For i = 2 To Finalrow
            If Worksheets("Sheet2").Cells(i, 1) = foundrange 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
                'Postal & 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

                Range("B12").Select
            End If
        Next i

    Set cC = New clsMsgbox
        cC.Title = "Search Customer"
        cC.Prompt = "Added Customer" & vbNewLine & "" & vbNewLine & "Is this the customer you were looking for?"
        cC.Icon = Question + DefaultButton2
        cC.ButtonText1 = "Yes"
        cC.ButtonText2 = "No"
         iR = cC.MessageBox()
        If iR = Button1 Then
            'Leave content in range
        ElseIf iR = Button2 Then
            Range("B12:E16").Select
            Selection.ClearContents
            Range("B12").Select

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

    End Sub

Thanks anyway!