Creating Separate Workbooks Based off of Values in Field

[BrittKnee]

Hi All,

I am trying to create separate workbooks for each value in a field. Basically, I have 45 different Departments and need to create a workbook for each with the data in the main worksheet. I've been able to do this by creating separate sheets and then creating workbooks, but for some reason it's going extra slow, so I was hoping to take the step of creating the sheet out. My data is in a table called "DetailData" and the field name is Department. I have already defined a filepath to save to and named in Departments & Format(Date, "mm.dd.yy"). I think I can navigate the saving part, it's just getting the workbooks created. All help is appreciated!

 

[BrittKnee]

This is what I've put together so far:

Option Explicit

Sub Create_Dept_WS()

Dim DeptField, DeptName As Range
Dim wsht, DataWSheet, WSheet, sht As Worksheet
Dim NewWB As Workbook
Dim tbl As ListObject
Dim RngRange01, Rng As Range
Dim StrOldValue, StrNewValue, FolderPath, Filename As String



Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Create Folder for Date

    FolderName = "Dept Vacancies " & Format(Date, "mm.dd.yy")

    MkDir "S:\Business Partners\Vacancy Reports - Split" & "\" & FolderName
   


'Create Detail Tab

Sheets("Raw Data").Copy after:=Sheets("Raw Data")
ActiveSheet.Name = "Detail"

'Convert Detail to Table

Set wsht = Sheets("Detail")
wsht.Activate

ActiveSheet.ListObjects.Add(xlSrcRange, _
Range("A1", Range("A1").End(xlToRight).End(xlDown)), , xlYes).Name _
    = "Detail"
    
'Set tbl = Sheets("Detail").ListObject("Detail")

'Create dept worksheets


Set DataWSheet = Worksheets("Detail")
Set DeptField = DataWSheet.Range("Detail[Department]")

'Change Name > 31 Characters

    StrOldValue = "OLD VALUE"
    StrNewValue = "NEW VALUE"
    
    ActiveSheet.AutoFilter.Range.AutoFilter Field:=2, Criteria1:=StrOldValue


    If Cells(ActiveSheet.AutoFilter.Range.Rows.Count + 1, 1).End(xlUp).Row = 1 Then
        MsgBox "No records found.", , "No records found"
        Exit Sub
    End If

      With ActiveSheet.AutoFilter.Range
        Set RngRange01 = Range("Detail[Department]").SpecialCells(xlCellTypeVisible)
    End With
    
    ActiveSheet.ListObjects(1).AutoFilter.ShowAllData


'Loop through each Department

For Each DeptName In DeptField
        
        Set NewWB = Workbooks.Add
        'NewWB.Name = DeptName 'named after that department
        
        
        DataWSheet.Range("A1", DataWSheet.Range("A1").End(xlToRight)).Copy Destination:=NewWB.Range("A1") 'and copy the headings to it
        
        DeptName.Offset(0, -1).Resize(1, 23).Copy Destination:=NewWB.Range("A2") ' then copy and paste the record to i
        
        ActiveSheet.Name = DeptName
        
        Application.ActiveWorkbook.SaveAs Filename:="S:\Reports - Split" & "\" & FolderName & "\" & sht.Name & ".xlsx"

 Application.ActiveWorkbook.Close False
 
Next DeptName



Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Also, when activating the original workbook, I will need to recognize it by a partial name. TIA!

 

[BrittKnee]

Hi All,

I'm still trying to get this to work. I've modified the code a bit (see below). The issue now is that it : 1) Doesn't Copy the header row and 2.) Gets stuck creating the second workbook (never debugs, but just repeats over and over). Again, any and all help is appreciated.

Option Explicit

Sub Create_Dept_WB()


Dim wsht, sht, nsh As Worksheet
Dim nwb As Workbook
Dim DeptName, DeptField, RngRange01 As Range
Dim StrOldValue, StrNewValue, FolderPath, Filename, FolderName, FromPath, ToPath, FileExt, FNames As String
Dim tbl As ListObject
Dim i As Integer



Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Create Folder for Date

    FolderName = "Dept Vacancies " & Format(Date, "mm.dd.yy")

    MkDir "S:\DeptReports" & "\" & FolderName


'Create Detail Tab

Sheets("Raw Data").Copy after:=Sheets("Raw Data")
ActiveSheet.Name = "Detail"

'Convert Detail to Table

Set wsht = Sheets("Detail")
wsht.Activate

ActiveSheet.ListObjects.Add(xlSrcRange, _
Range("A1", Range("A1").End(xlToRight).End(xlDown)), , xlYes).Name _
    = "Detail"
 

'Change Name > 31 Characters

    StrOldValue = "Security Business Resource Management"
    StrNewValue = "Security Bus Resource Mgmt"
    
    ActiveSheet.AutoFilter.Range.AutoFilter Field:=2, Criteria1:=StrOldValue

    If Cells(ActiveSheet.AutoFilter.Range.Rows.Count + 1, 1).End(xlUp).Row = 1 Then
        MsgBox "No records found.", , "No records found"
        Exit Sub
    End If

      With ActiveSheet.AutoFilter.Range
        Set RngRange01 = Range("Detail[Department]").SpecialCells(xlCellTypeVisible)
    End With

    RngRange01.Value = StrNewValue
     ActiveSheet.ListObjects(1).AutoFilter.ShowAllData


'Create Workbooks

Set DeptField = wsht.Range("Detail[Department]")

For Each DeptName In DeptField


    Set nwb = Workbooks.Add
    Set nsh = nwb.Sheets(1)


   DeptName.Offset(0, -1).Resize(1, 23).Copy nsh.Range("A1")
    
    'wsht.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
    nsh.UsedRange.EntireColumn.ColumnWidth = 15
    
   
    nsh.Name = DeptName

    nwb.SaveAs Filename:="S:\DeptReports" & "\" & FolderName & "\" & nsh.Name & ".xlsx"
    nwb.Close False
    'wsht.AutoFilterMode = False
    
Next DeptName


MsgBox "Macro Complete"

End Sub