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

Report
Posts
1
Registration date
Friday August 25, 2017
Status
Member
Last seen
August 25, 2017
-
vcoolio
Posts
1254
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
January 17, 2020
-
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 .....


1 reply

Posts
1254
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
January 17, 2020
208
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
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 5455 users have said thank you to us this month