Create new workbook for each item in the list

[Balajibenz]

Hi Can someone help with below requirement with VBA code.

I have got two sheets sheet1 and sheet2. sheet1 got data in A-X and sheet2 got a list in column B as below.

Manager
Max
Harry
Murat
Vamsi
Adam

what i am looking for is code that loop through the above list and for each name it has to filter the name sheet1 data in column "X" and then copy the filtered (A-X including headers) data and paste (should be in same format as source) it in new workbook and save the workbook in the same path as the currentworkbook. sheet name in new new workbook should also be the manager name.

 

[JLGWhiz]

See if this is what you want.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, wb As Workbook
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
    For Each c In sh2.Range("B2", sh2.Cells(Rows.Count, 2).End(xlUp))
        sh1.UsedRange.AutoFilter 24, c.Value
            If sh1.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
                Set wb = Workbooks.Add
                sh1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
                wb.Sheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
                wb.Sheets(1).Range("A1").PasteSpecial xlPasteFormats
                wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ",xlsx"
                wb.Close False
                sh1.AutoFilterMode = False
            End If
    Next
End Sub

 

[mumps]

Try:

Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim srcWB As Workbook, manager As Range
    Set srcWB = ThisWorkbook
    For Each manager In Sheets("Sheet2").Range("B2", Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp))
        With Sheets("Sheet1")
            .Range("A1").CurrentRegion.AutoFilter 24, manager
            .AutoFilter.Range Copy
            Workbooks.Add
            ActiveSheet.Name = manager
            Range("A1").PasteSpecial
            With ActiveWorkbook
                .SaveAs srcWB.Path & Application.PathSeparator & manager & ".xlsx"
                .Close False
            End With
        End With
    Next manager
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[JLGWhiz]

Correct the typo in this line

wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx"

 

[Balajibenz]

Correct the typo in this line

wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx"

Thanks mate that helped and worked perfectly.

 

[JLGWhiz]

Thanks mate that helped and worked perfectly.

You're welcome,
regards, JLG

 

[sfos83]

Hi all,

For a simplified variation on this theme, I was hoping to simply create new workbooks named after a list of names in column A, and save them to a drive and close them. For some reason I cannot get it to work, no matter the variation on your code.

The length of the list will be variable (between 1 and 20 files) and I'd like to save it in directory "C:\Users\Steve\Desktop\PA Test Folder\Test Files\OneDrive Files\"

Could you please help? I'm going crazy!
Thanks
Steve