Split data to separate worksheets based on column value

[elitef]

Hello All,

I currently have a VBA for splitting the large amount of data across multiple sheets within the same workbook, which works fine, but I want it to split into separate workbooks and save in a set folder so I dont have to manually do this.

My data is from A:M
With the first row being the header row.

Master has more columns then the extracted data in each sheet as I do not want to include all columns for each split. So columns E, J, K, and L are excluded from the split

This is the code I currently have:

Sub SplitDataIntoSheets()
Dim rng As Range
Dim rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Set rng = Sheets("Sheet1").Range("F2")
Set rng1 = Sheets("Sheet1").Range("A2:D2,F2:I2,M2")
vrb = False
Do While rng <> ""
    For Each sht In Worksheets
        If sht.Name = Left(rng.Value, 31) Then
            sht.Select
            Range("A2").Select
            Do While Selection <> ""
                ActiveCell.Offset(1, 0).Activate
            Loop
            rng1.Copy ActiveCell
            ActiveCell.Offset(1, 0).Activate
            Set rng1 = rng1.Offset(1, 0)
            Set rng = rng.Offset(1, 0)
            vrb = True
        End If
    Next sht
    If vrb = False Then
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = Left(rng.Value, 31)
    Columns("A").ColumnWidth = 25
    Columns("B").ColumnWidth = 25
    Columns("C").ColumnWidth = 12
    Columns("D").ColumnWidth = 12
    Columns("E").ColumnWidth = 25
    Columns("F").ColumnWidth = 19
    Columns("G").ColumnWidth = 35
    Columns("H").ColumnWidth = 16
    Columns("I").ColumnWidth = 10
    Sheets("Sheet1").Range("A1:D1,F1:I1,M1").Copy ActiveSheet.Range("A1")
    Range("A2").Select
    Do While Selection <> ""
        ActiveCell.Offset(1, 0).Activate
    Loop
    rng1.Copy ActiveCell
    Set rng1 = rng1.Offset(1, 0)
    Set rng = rng.Offset(1, 0)
    End If
vrb = False
Loop
End Sub

 

[elitef]

anyone?