Workbook Splitter

V

VeeBa

Board Regular
Joined
Apr 22, 2017
Messages
82
Hi Excel Experts! Anyone here who can help me with file splitting? Basically, the macro is in one workbook which contains the main data. What I want the macro to do is to split the main data into different new workbooks - I need to filter one column which will define how many files I need to create (copy and paste, format into the format required and save the files in a folder.)

I am doing this everyday and it would really help me if I could somehow automate this since the workbooks I need to split usually reaches 15-30 workbooks a day. And I know it could be done easier. Please see the link below for my unfinished workbook. Thank you in advance!

https://www.dropbox.com/s/6ahrmgs1k9u4cyd/testing_1.3.xlsm?dl=0
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Hi VeeBa
You could use this
Code: 
Sub ExtractSheetsFromColA()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s As String
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$M$" & Format(lr)).AutoFilter Field:=2, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets("Raw").Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
Cheers
Sergio
 
Upvote 0
Hi VeeBa
I notice I made a mistake in the VBA it should be Field=1 not 2, so here is the new VBA, also I added to create new files, as you need, instead of new Sheets for each value in column A
Code: 
Sub ExtractSheetsFromColA()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s As String
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$M$" & Format(lr)).AutoFilter Field:=1, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows("testing_1.3.xlsm").Activate
    Sheets("Raw").Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
You should be careful running the macro, it takes for ever to copy 437 different values, so you should try with smaller set of data
Also change Windows("testing_1.3.xlsm").Activate to your real file name instead of testing_1.3.xlsm
Cheers
Sergio
 
Last edited:
Upvote 0
sergioMabres said:
Hi VeeBa
I notice I made a mistake in the VBA it should be Field=1 not 2, so here is the new VBA, also I added to create new files, as you need, instead of new Sheets for each value in column A
Code: 
Sub ExtractSheetsFromColA()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s As String
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$M$" & Format(lr)).AutoFilter Field:=1, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows("testing_1.3.xlsm").Activate
    Sheets("Raw").Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
You should be careful running the macro, it takes for ever to copy 437 different values, so you should try with smaller set of data
Also change Windows("testing_1.3.xlsm").Activate to your real file name instead of testing_1.3.xlsm
Cheers
Sergio
Click to expand...

Hi Sergio! Sorry for getting back to you just now and thank you for your inputs! :) I tried running the code, however, the filter is set on column A, I need the filter to be on column T, filter per item and copy whole data column A to U, create new sheet and paste there. After pasting, I need to include a pivot in the coding because I need to format first the data before saving the new workbook..I tried changing the above codes from A to T but it is still filtering column A (not sure why). Can you please help with this? I can just insert the pivot code by recording.. Thank you!
 
Upvote 0
Hi VeeBa
Here it is
Code: 
Sub ExtractSheetsFromColA()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s As String
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-<acronym title="visual basic for applications">VBA</acronym>
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("T2:T" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$U$" & Format(lr)).AutoFilter Field:=20, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows("testing_1.3.xlsm").Activate
    Sheets("Raw").Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
Cheers
Sergio
 
Upvote 0
sergioMabres said:
Hi VeeBa
Here it is
Code: 
Sub ExtractSheetsFromColA()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s As String
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-<acronym title="visual basic for applications">VBA</acronym>
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("T2:T" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$U$" & Format(lr)).AutoFilter Field:=20, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows("testing_1.3.xlsm").Activate
    Sheets("Raw").Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
Cheers
Sergio
Click to expand...

Thanks Sergio for the codes! I am also in need if these logic..in the pivot part..Should i insert the pivot coding after that code? Also is there a way to save the files that i generate and the filaname based on what i filtered? For example i filtered JP on column T. When i save the new workbook, i want its name to be JP (which is the same with what i filter) then create an outlook email and attach that file.. is this possible?
 
Last edited:
Upvote 0
Yes it is possible, your Pivot, & saving code should go between this two lines
Sheets(s).Move
' Your pivot and saving code here
Windows("testing_1.3.xlsm").Activate

Cheers
Sergio
 
Upvote 0
sergioMabres said:
Yes it is possible, your Pivot, & saving code should go between this two lines
Sheets(s).Move
' Your pivot and saving code here
Windows("testing_1.3.xlsm").Activate

Cheers
Sergio
Click to expand...

Hello Sergio - Is there a way to change below code to like myworkbook instead of a specific file name? just to avoid debugging?

Windows("testing_1.3.xlsm").Activate
 
Upvote 0
Sure here it is no fix name for file nor sheet
Code: 
Sub ExtractSheetsFromColT()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s, n, s0 As String
n = ActiveWorkbook.Name
s0 = ActiveSheet.Name
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("T2:T" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$U$" & Format(lr)).AutoFilter Field:=20, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows(n).Activate
    Sheets(s0).Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
Cheers
Sergio
 
Upvote 0
sergioMabres said:
Sure here it is no fix name for file nor sheet
Code: 
Sub ExtractSheetsFromColT()
' Extracts into sheets by Sergio Mabres
Dim d As Object, c As Variant, i As Long, lr As Long, s, n, s0 As String
n = ActiveWorkbook.Name
s0 = ActiveSheet.Name
Range("A1").Select
Selection.AutoFilter
' From hiker95, 07/26/2012
' From http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("T2:T" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
For i = 0 To d.Count - 1
    s = d.Keys()(i)
    ActiveSheet.Range("$A$1:$U$" & Format(lr)).AutoFilter Field:=20, Criteria1:=s
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveSheet.Name = s
    Sheets(s).Move
    Windows(n).Activate
    Sheets(s0).Select
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
Next i
End Sub
Cheers
Sergio
Click to expand...

Hi Sergio thank you for the help! I will try this and let you know
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA to split table and retain formatting
Replies
1
Views
208
XLfriend777
XLfriend777
H
  • Solved
Set Dim workbook name via 'InputBox'
Replies
5
Views
362
heathball
H
T
  • Solved
Copy and Past the Data from Multiple Closed Workbooks
2
Replies
16
Views
895
thespardian
T
P
  • Solved
VBA to open file using Cell for the path
Replies
4
Views
581
Peter Davison
P
B
  • Question
Update of All Workbooks in a folder from the main Workbook
Replies
2
Views
281
BebeM
B

Forum statistics

Threads
1,214,918
Messages
6,122,255
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top