Regels kopiëren

[pe34]

Hallo allemaal,
Ik momenteel bezig met het schrijven van een programma. Ik heb hier al een stuk van maar zou dit graag nog verder aan passen.
De aanpassing die ik wil maken zijn:
Alle zoek resultaten van A2 weergeven in A3 en verder naar beneden
Zoekresultaten van F2 weggeven in F3 en verder naar beneden
Zoekresultaten van k2 weergeven in k3 en verder
Enzo verder wie zou mijn hier mee kunnen helpen?

Al vast bedankt

Bij deze het programa tot zo ver

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
On Error Resume Next
[pertypen!A3:E65536].ClearContents
With Sheets("motoren")
Set c = .Range("b3:b100").Find([pertypen!B2], , xlValues, xlWhole)
firstaddress = c.Address
Do
Sheets("pertypen").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Resize(1) = c.EntireRow.Resize(1).Value
Set c = .Range("b3:b100").FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End With
End If
Sheets("pertypen").Columns("A").AutoFit
End Sub

 

[Mark xl]

Hoi pe34,

Kun je je code ook in een codeblok zetten? dat leest makkelijker.
al wordt het er niet veel leesbaarder op

Verder zou je je code een stuk beter kunnen structureren, maar dat lijkt me duidelijker
als ik je alvast een voorzetje geef....:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim firstaddress As String
Dim kolom As String
Dim c As Range

'Target overlapt één van de gespecificeerde cellen en is één enkele cel
If Not Intersect(Target, Zoekvelden("B2", "F2", "K2")) Is Nothing And _
    Target.Columns.Count = 1 And _
    Target.Rows.Count = 1 Then
    
    kolom = Split(Target.Address, "$")(1)
    
    Sheets("pertypen").Range("A3:E65536").ClearContents
    
    Set c = Sheets("motoren").Range(kolom & "3:" & kolom & "100").Find( _
                    What:=Target, _
                    LookIn:=xlValues, _
                    Lookat:=xlWhole, _
                    MatchCase:=False)

    If c Is Nothing Then
        Exit Sub
    Else
        firstaddress = c.Address
    End If
            
    Do
        Sheets("pertypen").Range("A65535").End(xlUp).Offset(1).EntireRow = _
                                                        c.EntireRow.Value
        Set c = Sheets("motoren").Range(kolom & "3:" & kolom & "100").FindNext(c)
    
    Loop Until c.Address = firstaddress

    Sheets("pertypen").Columns("A:P").AutoFit

End If

End Sub

Function Zoekvelden(ParamArray vAdressen() As Variant) As Range
'geef als parameters de velden op waar je zoekwaarden intikt
Dim rVelden As Range
Dim i As Long

    Set rVelden = Range(vAdressen(LBound(vAdressen)))
    
    For i = LBound(vAdressen) + 1 To UBound(vAdressen)
        Set rVelden = Union(rVelden, Range(vAdressen(i)))
    Next

    Set Zoekvelden = rVelden

End Function

Is dit ongeveer de bedoeling?