Try the following VBA code:-
'Create new work books, transfer data.
Dim dic As Object, rng As Range, ws As Worksheet, mypath As String, lr As Long
Set dic = CreateObject("Scripting.Dictionary")
Set ws = Sheet1
mypath = ThisWorkbook.Path & "\"
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For nrow = lr To 2 Step -1 '----> Next row
If (Not dic.exists(.Cells(nrow, "D").Value)) Then
dic.Add .Cells(nrow, "D").Value, .Cells(nrow, "D").Value
Set rng = .Range("A1:I" & .Cells(Rows.Count, 1).End(xlUp).Row) '----> Change "I" to whatever is your last column.
rng.AutoFilter 4, Range("D" & nrow).Value
ActiveWorkbook.SaveAs Filename:=mypath & .Range("D" & nrow).Value & ".xlsx"
.AutoFilterMode = False
MsgBox "Done!", vbExclamation
Application.CutCopyMode = False
Application.ScreenUpdating = True
The code should create new work books for each patient named in Column D and transfer the relevant rows of data to sheet1 of each work book. Each new work book is named after each patient, surname first. Each new work book is saved to the same folder which holds the originating work book (line 10 in the code above).
Test the code in a copy of your work book first.
I hope that this helps.