dgxcook
08-16-2018, 06:48 AM
Hello!
I have a daily task of splitting a report with sales data into separate workbooks by vendor name and distributing it to them accordingly.
I have been using two macros to do this, one to split the data into separate worksheets and another to split those sheets into separate workbooks. I have these saved in my personal.xlsb file, but I am having to copy the module into the workbook I am using each time because it tries to split up the sheets in the personal.xlsb file, not the active book I am working in.
I am hoping to find two things, one being a single macro that does both of these tasks at once. The other being a way to avoid copying the module to each workbook I need to use.
The below is what I am using to separate column a into individual sheets.
Sub columntosheets()
Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
This is what I am using to split worksheets into work books and save them as sheetname.xlsx in the folder that the original workbook is saved in.
Sub SplitSheets() Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String
Set wb1 = ThisWorkbook
sPath1 = wb1.Path
Application.ScreenUpdating = False
For Each ws In wb1.Worksheets
If ws.Visible Then
ws.Copy
Set wb2 = ActiveWorkbook
sPath2 = sPath1 & Application.PathSeparator & ws.Name
On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0
Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wb2.Close(False)
End If
Next
wb1.Activate
Application.ScreenUpdating = False
End Sub
Any help would be greatly appreciated!!
I have a daily task of splitting a report with sales data into separate workbooks by vendor name and distributing it to them accordingly.
I have been using two macros to do this, one to split the data into separate worksheets and another to split those sheets into separate workbooks. I have these saved in my personal.xlsb file, but I am having to copy the module into the workbook I am using each time because it tries to split up the sheets in the personal.xlsb file, not the active book I am working in.
I am hoping to find two things, one being a single macro that does both of these tasks at once. The other being a way to avoid copying the module to each workbook I need to use.
The below is what I am using to separate column a into individual sheets.
Sub columntosheets()
Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
This is what I am using to split worksheets into work books and save them as sheetname.xlsx in the folder that the original workbook is saved in.
Sub SplitSheets() Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String
Set wb1 = ThisWorkbook
sPath1 = wb1.Path
Application.ScreenUpdating = False
For Each ws In wb1.Worksheets
If ws.Visible Then
ws.Copy
Set wb2 = ActiveWorkbook
sPath2 = sPath1 & Application.PathSeparator & ws.Name
On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0
Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wb2.Close(False)
End If
Next
wb1.Activate
Application.ScreenUpdating = False
End Sub
Any help would be greatly appreciated!!