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:
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:
VBA Code:
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