Macro to Create New Workbook and Copy Data at Each Change of X

Closed
greatdanejes Posts 1 Registration date Friday August 25, 2017 Status Member Last seen August 25, 2017 - Aug 25, 2017 at 03:08 PM
vcoolio Posts 1362 Registration date Thursday July 24, 2014 Status Moderator Last seen September 29, 2022 - Aug 26, 2017 at 06:26 AM
Hello,

I get large spreadsheets with thousands of lines with close to 200 patient names (one patient contains multiple lines for each different date of service). Is there a macro that can be written to create a new workbook at each change in PATIENT_NAME that will also keep the first row with the column headers on each workbook? Then, can it save each file by using the PATIENT_NAME, PATIENT ID, and date? (Note that patient's names have commas d/t LAST,FIRST format so not sure if this can be used?)

FACILITY_CODE FAC_NAME PATIENT_ID PATIENT_NAME .....


Related:

1 reply

vcoolio Posts 1362 Registration date Thursday July 24, 2014 Status Moderator Last seen September 29, 2022 252
Aug 26, 2017 at 06:26 AM
Hello GreatDaneJess,

Try the following VBA code:-


Sub GreatDaneJes()

'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

With ws
    
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
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveSheet.Columns.AutoFit
            ActiveWorkbook.SaveAs Filename:=mypath & .Range("D" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
           .AutoFilterMode = False
End With

MsgBox "Done!", vbExclamation
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


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.

Cheerio,
vcoolio.
2