Divide one excel workbook to many
Hi Excel Experts,
Kindly support me to solve this complicated issue:
Actually, I have a workbook with three sheets each one of them contains several rows (1-250)
Each row ended with a cell and its value should be one of three values (Promotion, Pending or Ignore)
More details:
Sheet 1 name : HRDept , the cell is in column = M
Sheet 2 name : HRDet ,the cell is in column = N
Sheet 3 name : HROff ,the cell is in column = P
Now, My project is to extract rows ended with “Promotion” from the three worksheets to external new workbook “Called Promotion” and distribute them into three worksheets inside it with same worksheets’ names in the original one.
And to do this with the rest “Pending & Ignore”
Is this applicable?!! Thanks for any help
Kindly find my example inside the attachments
| Attachment | Size |
|---|---|
| Source File.xlsx | 11.43 KB |
| Promotion.xlsx | 9.42 KB |
Copy the following code in a
Copy the following code in a general module of your source file and run.
Sub DivideWorkbook()
Dim wbk As Workbook
Dim x As Integer
Dim rng As Range
Set wbk = Workbooks.Add
For x = 1 To ThisWorkbook.Worksheets.Count
wbk.Worksheets(x).Name = ThisWorkbook.Worksheets(x).Name
Set rng = ThisWorkbook.Worksheets(x).UsedRange '.AutoFilter Field:=13, Criteria1:="Promotion"
rng.AutoFilter Field:=rng.Columns.Count, Criteria1:="Promotion"
rng.SpecialCells(xlCellTypeVisible).Copy
wbk.Worksheets(x).Range("A1").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets(x).AutoFilterMode = False
Next x
wbk.SaveAs ThisWorkbook.Path & "\" & "Promotion"
Set rng = Nothing
Set wbk = Nothing
End Sub
Divide one excel workbook to many
Hi Vishesh and thanks for support
the code work fine but actually I tried to modify to make it able to extract the rest of rows to additional two files
but this doesn’t work wit error message
kindly advice for below code
Also can we make the new generated excel files closed and saved by themselves
----------
----------
Sub DivideWorkbook()
Dim wbk As Workbook
Dim x As Integer
Dim Y As Integer
Dim Z As Integer
Dim rng As Range
Set wbk = Workbooks.Add
For x = 1 To ThisWorkbook.Worksheets.Count
wbk.Worksheets(x).Name = ThisWorkbook.Worksheets(x).Name
Set rng = ThisWorkbook.Worksheets(x).UsedRange
rng.AutoFilter Field:=rng.Columns.Count, Criteria1:="Promotion"
rng.SpecialCells(xlCellTypeVisible).Copy
wbk.Worksheets(x).Range("A1").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets(x).AutoFilterMode = False
Next x
wbk.SaveAs ThisWorkbook.Path & "\" & "Promotion"
Set rng = Nothing
Set wbk = Nothing
For Y = 1 To ThisWorkbook.Worksheets.Count
wbk.Worksheets(Y).Name = ThisWorkbook.Worksheets(Y).Name
Set rng = ThisWorkbook.Worksheets(Y).UsedRange
rng.AutoFilter Field:=rng.Columns.Count, Criteria1:="Pending"
rng.SpecialCells(xlCellTypeVisible).Copy
wbk.Worksheets(Y).Range("A1").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets(Y).AutoFilterMode = False
Next Y
wbk.SaveAs ThisWorkbook.Path & "\" & "Pending"
Set rng = Nothing
Set wbk = Nothing
For Z = 1 To ThisWorkbook.Worksheets.Count
wbk.Worksheets(Z).Name = ThisWorkbook.Worksheets(Z).Name
Set rng = ThisWorkbook.Worksheets(Z).UsedRange
rng.AutoFilter Field:=rng.Columns.Count, Criteria1:="Ignore"
rng.SpecialCells(xlCellTypeVisible).Copy
wbk.Worksheets(Z).Range("A1").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets(Z).AutoFilterMode = False
Next Z
wbk.SaveAs ThisWorkbook.Path & "\" & "Ignore"
Set rng = Nothing
Set wbk = Nothing
End Sub
Modified Code
Sub CallMe()
Application.ScreenUpdating = False
Call DivideWorkbook("Promotion")
Call DivideWorkbook("Pending")
Call DivideWorkbook("Ignore")
Application.ScreenUpdating = True
End Sub
Sub DivideWorkbook(strCriteria As String)
Dim wbk As Workbook
Dim x As Integer
Dim rng As Range
Set wbk = Workbooks.Add
For x = 1 To ThisWorkbook.Worksheets.Count
wbk.Worksheets(x).Name = ThisWorkbook.Worksheets(x).Name
Set rng = ThisWorkbook.Worksheets(x).UsedRange
rng.AutoFilter Field:=rng.Columns.Count, Criteria1:=strCriteria
rng.SpecialCells(xlCellTypeVisible).Copy
wbk.Worksheets(x).Range("A1").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets(x).AutoFilterMode = False
Next x
wbk.SaveAs ThisWorkbook.Path & "\" & strCriteria
wbk.Close False
Set rng = Nothing
Set wbk = Nothing
End Sub
Divide one excel workbook to many
VBA + Vishesh Hands = Excel Magic
Thanks it's working extremely fine
just a small issue
can we modify the copying process to copy only values. So, in case there is a formula only the final value will copied to the other sheets from the source one .
In place of xlPasteAll use
In place of xlPasteAll use xlPasteValues in the code.