if exists find last values in variable rows

Try this.

Sub zoek_gebuiker()

Dim c As Range, firstaddress As String, c1 As Range, c2 As Range, v

Application.ScreenUpdating = False

With Blad1.Range("B1", Blad1.Range("B" & Rows.Count).End(xlUp))
    Set c = .Find(What:="Medewerker:", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not c Is Nothing Then
        firstaddress = c.Address
        Do
            c.Offset(0, 1).Copy
            uitvoerBlad.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Set c1 = .Find(What:="Conversie", After:=c, Lookat:=xlWhole, SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            Set c2 = Blad1.Cells.Find(What:="Totaal", After:=c, Lookat:=xlWhole, SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c1 Is Nothing And Not c2 Is Nothing Then
                Blad1.Cells(c1.Row, c2.Column).Copy
                uitvoerBlad.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                Blad1.Cells(c1.Row + 1, c2.Column).Copy
                uitvoerBlad.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
            End If
            v = Application.Match(c.Offset(, 1), uitvoerBlad.Columns("K:K"), 0)
            If IsNumeric(v) Then
                uitvoerBlad.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = Application.Index(uitvoerBlad.Columns("L:L"), v, 1)
            End If
            Set c = .Find(What:="Medewerker:", After:=c1, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        Loop While c.Address <> firstaddress
        
    End If
End With

Application.ScreenUpdating = True

End Sub

or

Sub snb()
  On Error Resume Next
  With Sheets("Invoer").UsedRange
    For j = 1 To 2
      With .Columns(Choose(j, 1, 3))
        jj = 1
        .AutoFilter 1, Choose(j, "Medewerker*", "Totaal*")
        For Each cl In .Offset(1).SpecialCells(xlCellTypeVisible)
          If jj + j = 2 Then sq = Cells(1, 20).Resize(.Offset(1).SpecialCells(12).Count, 4)
          If j = 1 Then
            sq(jj, 1) = cl.Offset(, 1)
            sq(jj, 2) = Sheets("Conversie Tool").Columns(11).Find(sq(jj, 1), , xlValues, xlWhole).Offset(, 1).Value
          Else
            sq(jj, 3) = cl.End(xlToRight).Offset(-1)
            sq(jj, 4) = cl.End(xlToRight)
          End If
          jj = jj + 1
        Next
        .AutoFilter
      End With
    Next
  End With
  Sheets("Conversie Tool").Cells(5, 3).Resize(UBound(sq), UBound(sq, 2)) = sq
End Sub

Originally Posted by snb

or

Sub snb()
  On Error Resume Next
  With Sheets("Invoer").UsedRange
    For j = 1 To 2
      With .Columns(Choose(j, 1, 3))
        jj = 1
        .AutoFilter 1, Choose(j, "Medewerker*", "Totaal*")
        For Each cl In .Offset(1).SpecialCells(xlCellTypeVisible)
          If jj + j = 2 Then sq = Cells(1, 20).Resize(.Offset(1).SpecialCells(12).Count, 4)
          If j = 1 Then
            sq(jj, 1) = cl.Offset(, 1)
            sq(jj, 2) = Sheets("Conversie Tool").Columns(11).Find(sq(jj, 1), , xlValues, xlWhole).Offset(, 1).Value
          Else
            sq(jj, 3) = cl.End(xlToRight).Offset(-1)
            sq(jj, 4) = cl.End(xlToRight)
          End If
          jj = jj + 1
        Next
        .AutoFilter
      End With
    Next
  End With
  Sheets("Conversie Tool").Cells(5, 3).Resize(UBound(sq), UBound(sq, 2)) = sq
End Sub

SNB,

Thanks, it realy shortens the code (and now i really don't understand it)
Sadly it does not give the desired effect, the wrong percentage is copied, now it copies the first percentage in column "conversie", not the total percentage. (last value in column "conversie").

However, you managed to solve the problem with the incorrect "associated aspect nr's" (see my reply to Stephen earlier)

Thanks

ABBOV