Split Worksheet
Solved/Closed
PMARI
-
Jun 22, 2011 at 10:56 PM
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Jul 2, 2011 at 08:22 AM
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Jul 2, 2011 at 08:22 AM
Related:
- Split Worksheet
- Transfer data from one excel worksheet to another automatically - Guide
- Linux split file into n parts - Guide
- Lg tv split screen - Guide
- How to automatically transfer data between sheets in Excel - Guide
- Grade formula in excel worksheet - Guide
1 response
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..
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..
Jun 23, 2011 at 12:12 PM
Thank you for coming back to post the answer.
Regards
Jun 23, 2011 at 12:15 PM
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 ?
Jun 24, 2011 at 08:59 AM
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
Jul 2, 2011 at 08:22 AM