Find Next ook kopieeren naar blad 2

[Rap261]

Goedemiddag!


Onderstaand heb ik een code die de Text in een TextBox terug vindt in blad 1 en vervolgens de gehele regel waar deze is gevonden kopieert naar blad 2.
Omdat de Text ook in andere cellen kan staan, zit er in de code een Find Next option zodat de volgend "hit" ook wordt geselecteerd.
Echter wordt deze volgende "hit" dan alleen geselecteerd maar niet meer gekopieerd naar blad 2 nieuwe regel.

Vraag is: welke aanvulling heb ik nodig om alle rijen waaring de gevonden Text staat te kopieren naar blad 2?

Private Sub CommandButton1_Click()
    Dim Zoekletter As String
    Dim Results As Range
    Dim c As Range
    Dim ans As Variant
        If Trim(TextBox1) <> "" Then 'field voor zoek ref
        Zoekletter = UCase("*" & TextBox1.Text & "*") 'zoek ref
        With ActiveSheet.Columns("D:DT") 'zoek bereik
            Set c = .Find(What:=Zoekletter, LookIn:=xlValues, _
            lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
            c.Select 'selecteerd de zoek ref
            c.Rows.EntireRow.Select 'selecteerd de rij van de gevonden zoek ref
            c.Rows.EntireRow.Copy Sheets(2).[A65536].End(xlUp).Offset(3, 0) 'kopieert de rij naar blad 2 (offset = regel)
            TextBox1 = ""
            Else
            MsgBox "Your search creteria    " & TextBox1.Text & "    was not found" & vbCr & "Please try again" 'no result message
            End If
    End With
    Else
        Cells.FindNext(After:=ActiveCell).Activate 'find next optie
    End If
End Sub

 

[sylvester-ponte]

hallo Ralph

heel raar er staat in je macro dat:
als de tekstbox leet is --> voer findnext uit

stuur eens een voorbeeld aub

stel dat het werkt.
wat als de tekst meer dan 2 keer voor komt?
moet die ook beplakt worden op blad2?

groet sylvester

 

[Rap261]

Hi Sylvester,


Marco werkt prima (zie bijlage) en iid als de text 2 of 3 of 10 keer voor komt dan moeten die regels ook naar blad 2

 

[sylvester-ponte]

ja ja Ralph, hij zet alles op elkaar (dus je ziet alleen de laatst gevonden oplossing) als je dat prima vind moet je dat zeker zo laten
maar dan kan de code eenvoudiger.
en als je geen zoektekst in geeft vind hij via cells.findnext de eeste lege cel in het werkblad

deze code komt vast niet van jou :d

groet sylvester

 

[Rap261]

Sylvester,

Als jij een eenvoudiger code hebt dan zie ik die graag maar heb je ook de oplossing voor het kopieer probleem?
De code komt van mij, anders kan ik hem je niet geven. maar idd ook ik heb hem ooit gekregen en verder aangepast to wat ie nu is

 

[sylvester-ponte]

probeer deze eens:

Private Sub CommandButton1_Click()
    Dim Zoekletter As String
    Dim Results As Range, EersteRij
    Dim C As Range
    Dim ans As Variant
    Sheets(2).UsedRange.ClearContents
    If Trim(TextBox1) <> "" Then
        Zoekletter = UCase("*" & TextBox1.Text & "*")
        With ActiveSheet.Columns("B:E")
            Set C = .Find(What:=Zoekletter, LookIn:=xlValues, _
                          lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not C Is Nothing Then
                EersteRij = C.Row
                Do
                C.Rows.EntireRow.Copy Sheets(2).[B65536].End(xlUp).Offset(3, -1)    'kopieert de rij naar blad 2 (offset = regel)
                Set C = .FindNext(C)
                Loop While Not C Is Nothing And C.Row <> EersteRij
            Else
                MsgBox TextBox1.Text & " niet gevonden."
            End If
        End With
    End If
End Sub

hij is nog niet perfect
typ maar een er in en kijk op blad2
groet sylvester

 

[sylvester-ponte]

deze is beter
nu zoek hij niet meer in de eerste regel
en springt hij met findnext steeds naar de volgende regel

Private Sub CommandButton1_Click()
    Dim Zoekletter As String, EersteRij, TempRij, C As Range
    Sheets(2).UsedRange.ClearContents
    If Trim(TextBox1) <> "" Then
        Zoekletter = UCase("*" & TextBox1.Text & "*")
        With ActiveSheet.Columns("B:E")
            Set C = .Find(What:=Zoekletter, After:=[E8], LookIn:=xlValues, _
                          lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not C Is Nothing Then
                EersteRij = C.Row
                Do
                    C.Rows.EntireRow.Copy Sheets(2).[B65536].End(xlUp).Offset(1, -1)    'kopieert de rij naar blad 2 (offset = regel)
                    Set C = .FindNext(Cells(C.Row + 1, "B"))
                Loop While Not C Is Nothing And C.Row <> EersteRij
            Else
                MsgBox TextBox1.Text & " niet gevonden."
            End If
        End With
    End If
End Sub

 

[Rap261]

Hi Sylvester,

Thanks voor je hulp. toegepast in het voorbeeld werkt het perfect alleen wanneer ik het scriptje copy/paste in het bestand waarvoor het bestemd is dan krijg ik natuurlijk een aantal fout meldingen. Ik heb ze allemaal kunnen oplossen op een na:

Set C = .FindNext(Cells(C.Row + 1, "A"))

Mis ik iets simpels? Ik kom er maar niet achter

 

[sylvester-ponte]

Ralfh, wil je de hele macro sturen

groet sylvester

 

[Rap261]

Ik miste iets simpels... "A" moet worden vervangen door "F"
Nog een aantal checks en indien goed, dan kan de vraag op opgelost

 

[Rap261]

Hi Sylvester,


gelukt!
Onderstaand de code aangepast en volledig werkend

Private Sub CommandButton1_Click()
    Dim Zoekletter As String, EersteRij, TempRij, C As Range
    'Sheets(2).UsedRange.ClearContents
    If Trim(TextBox1) <> "" Then
        Zoekletter = UCase("*" & TextBox1.Text & "*")
        With ActiveSheet.Columns("F:DX")
            Set C = .Find(What:=Zoekletter, After:=[DX18], LookIn:=xlValues, _
                          lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not C Is Nothing Then
                EersteRij = C.Row
                Do
                    C.Rows.EntireRow.Copy Sheets(2).[B65536].End(xlUp).Offset(1, -1)    'kopieert de rij naar blad 2 (offset = regel)
                    Set C = .FindNext(Cells(C.Row + 1, "F"))
                Loop While Not C Is Nothing And C.Row <> EersteRij
            Else
                MsgBox TextBox1.Text & " niet gevonden."
            End If
        End With
    End If
End Sub
[code]

Thanks voor je hulp en een prettig weekend