Scribd
Upload
169 views

Split Excel

This macro splits a master worksheet into multiple new worksheets based on unique values in a specified column, filters the data in each new worksheet to only show rows matching that worksheet's value, and saves each new worksheet as a separate file. The macro sets ranges for the data and unique filter values, copies the master sheet, renames each copy based on the unique values, filters the data in each copy to only show rows matching that worksheet's filter value, and saves and closes each filtered worksheet as a separate file.

Uploaded by

Anonymous kwxlhaK
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
169 views

Split Excel

This macro splits a master worksheet into multiple new worksheets based on unique values in a specified column, filters the data in each new worksheet to only show rows matching that worksheet's value, and saves each new worksheet as a separate file. The macro sets ranges for the data and unique filter values, copies the master sheet, renames each copy based on the unique values, filters the data in each copy to only show rows matching that worksheet's filter value, and saves and closes each filtered worksheet as a separate file.

Uploaded by

Anonymous kwxlhaK
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

Sub ExtractToNewWorkbook()

Dim ws As Worksheet

Dim wsNew As Workbook

Dim rData As Range

Dim rfl As Range

Dim state As String

Dim sfilename As String

Set ws = ThisWorkbook.Sheets("emp")

'Apply advance filter in your sheet

With ws

Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 11).End(xlUp))

.Columns(.Columns.Count).Clear

.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter


Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count,


.Columns.Count).End(xlUp))

state = rfl.Text

Set wsNew = Workbooks.Add

sfilename = state & ".xlsx"

'Set the Location

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename

Application.DisplayAlerts = False

ws.Activate

rData.AutoFilter Field:=6, Criteria1:=state

rData.Copy

Windows(state).Activate

ActiveSheet.Paste

ActiveWorkbook.Close SaveChanges:=True

Next rfl
Application.DisplayAlerts = True

End With

ws.Columns(Columns.Count).ClearContents

rData.AutoFilter

End Sub
-----------------------
Topic: Split a master tab into multiple sub tabs with 1 click
Scenario: You want to split the data on a master file into multiple small sub-tabs
by a chosen criteria (eg. Department, Country, etc.)
Function: Macro for Copy sheet, AutoFilter, and Loop

***Macro Code SEE COMMENT FOR IMPORTANT NOTICE***


Sub SplitandFilterSheet()
'Step 1 - Name your ranges and Copy sheet
'Step 2 - Filter by Department and delete rows not applicable
'Step 3 - Loop until the end of the list
Dim Splitcode As Range
Sheets("Master").Select
Set Splitcode = Range("Splitcode")

For Each cell In Splitcode


Sheets("Master").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = cell.Value

With ActiveWorkbook.Sheets(cell.Value).Range("MasterData")
.AutoFilter Field:=6, Criteria1:="NOT EQUAL TO" & cell.Value,
Operator:=xlFilterValues
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

ActiveSheet.AutoFilter.ShowAllData
Next cell
End Sub

---------------------
Sub copyDatabyCondition()
�copy data if column S isn�t empty
Dim wsSource As Worksheet
Dim wsTarget As Worksheet

Dim gSourceRow As Long, gSourceTotal As Long


Dim gTargetRow As Long

�intialization
Set wsSource = ThisWorkbook.Sheets(�INPUT�)
Set wsTarget = ThisWorkbook.Sheets(�Sheet2�)

�find the last row in both tables


gTargetRow = wsTarget.[A65536].End(xlUp).Row

With wsSource
�for each row in the source table
For gSourceRow = 11 To .[A65536].End(xlUp).Row
�column S isn�t empty?
If .Cells(gSourceRow, �S�) 0 Then
gTargetRow = gTargetRow + 1 �increment row no. & appending a new line
�copying a line from source table to target table
wsTarget.Range(�A� & gTargetRow & �:N� & gTargetRow).Value = _
.Range(�L� & gSourceRow & �:Y� & gSourceRow).Value
End If
Next
End With
End Sub

---------------------
Sub copycolumns()

Dim lastrow As Long, erow As Long


lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrow
If Sheet1.Cells(i, 6) = �Maharashtra� Then
Sheet1.Cells(i, 1).Copy
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet1.Paste Destination:=Worksheets(�Sheet2�).Cells(erow, 1)

Sheet1.Cells(i, 3).Copy
Sheet1.Paste Destination:=Worksheets(�Sheet2�).Cells(erow, 2)

Sheet1.Cells(i, 6).Copy
Sheet1.Paste Destination:=Worksheets(�Sheet2�).Cells(erow, 3)
End If

Next i
Application.CutCopyMode = False
Sheet2.Columns().AutoFit
Range(�A1�).Select

End Sub
--------------

Sub Splitziez()

Dim strPath As String


strPath = "Location of your file"
For Each sheetz0r In ThisWorkbook.Sheets
sheetz0r.Copy
Application.ActiveWorkbook.SaveAs Filename:=strPath & "\" & sheetz0r.Name &
".xlsx"
Application.ActiveWorkbook.Close False
Next
End Sub
-------------
I need a macro for following condition
suppose i have customer excel file in which first 7 rows is for header so, from 8th
rowrecords are start
i need to split rows of 500 record each in one file and save them with name
customer1,customer2,customer3,........
suppose i have customer file of 2540 records so it split in
customer1 which have header rows with record starts from 8th row to 507th row
customer2 which have header rows with record starts from 508th row to 1007th row
customer3 which have header rows with record starts from 1008th row to 1507th row
customer4 which have header rows with record starts from 1508th row to 2007th row
customer5 which have header rows with record starts from 2008th row to 2507th row
customer6 which have header rows with record starts from 2508th row to 2540th row

You might also like