Split Worksheet

Solved/Closed
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,

Is it possible to Split one worksheet to different workbooks( files). I am having a statement to be send to 10 branch offices.

sample link below,

http://www.speedyshare.com/files/29107785/BRS.XLS

in my worksheet column A having area name, this file to split area wise.

My code is below,

Sub SPLIT()
'
' SPLIT Macro
' SPLIT
'

'
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$25").AutoFilter Field:=1, Criteria1:="AMD"
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Application.WindowState = xlMinimized
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWindow.Close
ActiveSheet.Range("$A$1:$D$25").AutoFilter Field:=1, Criteria1:="IND"
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Application.WindowState = xlMinimized
Application.WindowState = xlMinimized
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWindow.Close
End Sub

But is not working.

Anybody can help me please.



1 reply

Hi,

Got the code.

Sub SplitFile()

Dim i As Long
Dim arrFruits As Variant, arrBooks() As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheet1.AutoFilterMode = False

arrFruits = Array("Apple", "Orange", "Grapes")
ReDim arrBooks(0 To UBound(arrFruits))

' Create workbooks.
For i = 0 To UBound(arrFruits)
Set arrBooks(i) = Workbooks.Add
Next

' Retrieve data by autofilter.
With Sheet1
For i = 0 To UBound(arrFruits)
.Range("A1:A3").AutoFilter Field:=1, Criteria1:=arrFruits(i)
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Workbooks(arrBooks(i).Name).Sheets(1).Range("A1").PasteSpecial
Next
End With

' Save all workbooks.
For i = 0 To UBound(arrBooks)
Workbooks(arrBooks(i).Name).SaveAs Filename:=ThisWorkbook.Path & "\" & arrFruits(i) & ".xlsx"
Next

' Clean-up.
Application.ScreenUpdating = False
Sheet1.AutoFilterMode = False
Application.DisplayAlerts = True

End Sub


Thanks..
Posts
6428
Registration date
Sunday June 6, 2010
Status
Moderator
Last seen
July 16, 2020

Greetings,
Thank you for coming back to post the answer.
Regards
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Thanks for posting your solution
what happens if there is no data for "Orange" ?
what happens if there is a new fruit MANGO that was not there before
what happens if "Orange" workbook is already there ?
Dear rizvisa1,

You are right, please see the corrected code.

Thanks for your response.

Regards,PM


Option Explicit

Sub ParseItems()

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Application.ScreenUpdating = False

vCol = 1

Set ws = Sheets("Original Data")

SvPath = "C:\Users\Desktop"

vTitles = "A1:Z1"

'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True


ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
ActiveWorkbook.Close False

ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm

ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
thanks for putting the solution.