Thread: Selecting test results of specific person

Try this..

Stick a button on the 'testoverzicht' sheet and run this code

Sub CollectPatientResults()
'Turn off screen updates
Application.ScreenUpdating = False
'Delete any previous data
Sheets("testoverzicht").Range("F2:AK500").ClearContents
'Store patient name
Patient = Sheets("testoverzicht").Range("C3").Value
'Activate Gevens2 sheet
Sheets("Gegevens2").Select
'Move to last row on sheet so we know how many rows to loop through
Range("A1").Select
Selection.End(xlDown).Select
LastRow = ActiveCell.Row
'Loop from row 2 to last row with data in
For x = 2 To LastRow
'Check if patient appears on this row
If Cells(x, 2).Value = Patient Then
'Copy Data starting from TestDatum column (E) to opmerkingen (AJ) of current row
Cells(x, 5).Resize(Selection.Rows.Count, Selection.Columns.Count + 31).Copy
'Paste Data into testoverzicht sheet
Sheets("testoverzicht").Select
'Go to bottom of sheet then up to next used row (So we can past data below last used row
Range("F65536").Select
Selection.End(xlUp).Select
'Paste Data
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'this clears the original copy from the clipboard
'Back to original sheet...
Sheets("Gegevens2").Select
End If
Next
'Back to testoverzicht sheet...
Sheets("testoverzicht").Select
'Turn back ON screen updates
Application.ScreenUpdating = True
End Sub

See if this works as you want.

Sub x()

Dim rData As Range

Application.ScreenUpdating = False

With Sheets("Gegevens2")
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=2, Criteria1:=Sheets("testoverzicht").Range("C3")
    With .AutoFilter.Range
        On Error Resume Next
        Set rData = .Offset(1, 4).Resize(.Rows.Count - 1, .Columns.Count - 4).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rData Is Nothing Then
            With Sheets("testoverzicht")
                If Len(.Range("F2")) > 0 Then
                    .Range("F2", .Range("F2").End(xlDown)).Resize(, 32).ClearContents
                End If
                rData.Copy
                .Range("F2").PasteSpecial xlValues
            End With
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

StephenR,

I tried your method and it works like a charm!

Johncassel also thanks for your input. I will save the code in case I run in to some kind of problem...

I also changed the code to a Worksheet_Change so it updates as soon as I select another person from the dropdown list...

Thanks again people, you saved my day! :-)