Spilt data in multiple sheet and save separately

[gssachin]

Hi,

I have one salary master sheet containing 5000 rows, 50 columns, I want to get filter data on basis of column "Location" and paste it in separate sheet in same workbook but in different worksheet and rename the sheet as that location name also that single sheet to be copy new workbook and rename as "Mar22_"Location Name"


So once I run the macro my master sheet will add sheets as per location wise and same time it will save separately in my location (i.e. C:\Mar 22 Salary)

Thanks in advance

 

[John_w]

Try this macro, which expects the data to be on a sheet named "Master" and the "Location" column is column A.

Public Sub Split_Sheet_By_Location()

    Dim saveInFolder As String
    Dim locations As Collection
    Dim locationCell As Range, locationKey As Variant
    Dim locationSheet As Worksheet
    
    saveInFolder = "C:\Mar 22 Salary\"
    If Right(Trim(saveInFolder), 1) <> "\" Then saveInFolder = Trim(saveInFolder) & "\"
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("Master")
    
        'Create collection of unique locations from column A
        
        Set locations = New Collection
        On Error Resume Next
        For Each locationCell In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            locations.Add locationCell.Value, CStr(locationCell.Value)
        Next
        On Error GoTo 0
        
        'Autofilter column A by each location and copy results to location sheet
        
        For Each locationKey In locations
        
            Set locationSheet = Get_Sheet(ThisWorkbook, CStr(locationKey))
            .UsedRange.AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:="=" & locationKey  'Field:=1 means column A
            .UsedRange.Copy locationSheet.Range("A1")
        
            Application.DisplayAlerts = False  'suppress warning if .xlsx file already exists - file is replaced
            locationSheet.Copy
            ActiveWorkbook.SaveAs saveInFolder & "Mar22_" & locationKey & ".xlsx"
            ActiveWorkbook.Close SaveChanges:=False
            Application.DisplayAlerts = True
        
        Next
        
        'Remove autofilter
            
        .UsedRange.AutoFilter
        .Activate
        
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub


Private Function Get_Sheet(wb As Workbook, sheetName As String) As Worksheet

    Set Get_Sheet = Nothing
    With wb
        On Error Resume Next
        Set Get_Sheet = .Worksheets(sheetName)
        On Error GoTo 0
        If Get_Sheet Is Nothing Then
            Set Get_Sheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            Get_Sheet.Name = sheetName
        Else
            Get_Sheet.Cells.Clear
        End If
    End With
    
End Function

 

[gssachin]

Hello John,

Thanks for reply.

Its works for me but after finishing macro its shows error
Run-time error '1004' :
Method 'Name' of object ' _worksheet' failed

Also its add a blank sheet

Apart from this its work as per my requirement.

If possible pls help to resolved above issue

Thanks in advance

 

[John_w]

Are there any blank cells in column A, which the code assumes is the Location?

 

[gssachin]

Hi, John,

Yes, when macro put filter to my location column its takes last row (i.e. "total") and it was a blank cell, now its working fine.

Thanks a lot....

 

[gssachin]

Hi John,

I want the new sheet should get autofit
I tried following code
Cells.select
Cells.autofit after copy locationsheet.Range ("A")
But it's delect some rows (note - my filter on row no 10, 1 row contain small image)

Or column b after its should get autofit also OK for me,

Thanks in advance ?