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

Question

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   .....


System Configuration: Windows / Chrome 60.0.3112.101

vcoolio · Accepted Answer

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.

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

1 response

Similar discussions

Subscribe To Our Newsletter!