Split Worksheet

Solved/Closed
PMARI - Jun 22, 2011 at 10:56 PM
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Jul 2, 2011 at 08:22 AM
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..
0
jack4rall Posts 6428 Registration date Sunday June 6, 2010 Status Moderator Last seen July 16, 2020
Jun 23, 2011 at 12:12 PM
Greetings,
Thank you for coming back to post the answer.
Regards
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 767
Jun 23, 2011 at 12:15 PM
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 ?
0
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
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 767
Jul 2, 2011 at 08:22 AM
thanks for putting the solution.
0