Hi Friends,
Need help on splitting of Workbook which has 15 worksheets each worksheet has common name/Common code can i split as per the common name/common Code into new workbook with the common name as file name. I have tried by a macro which is shared below but when I run the code it is split into file name & when checked the split file except the Common name of the file everything is coming & also the heading is not coming. Could you please correct the code or provide with a new code also sharing files for which I have done.
Thanks in advance.
Sub SplitWorkbookByBranch()
Dim ws As Worksheet
Dim branchNames As Collection
Dim branchName As Variant
Dim rng As Range
Dim newWorkbook As Workbook
Dim originalWorkbook As Workbook
Dim branchDict As Object
Dim cell As Range
Dim newSheet As Worksheet
Dim visibleRange As Range
' Initialize variables
Set originalWorkbook = ThisWorkbook
Set branchNames = New Collection
Set branchDict = CreateObject("Scripting.Dictionary")
' Collect unique branch names from the first worksheet (column C)
With originalWorkbook.Worksheets(1)
Set rng = .Range("C2:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
On Error Resume Next
For Each cell In rng
branchName = cell.Value
If Not branchDict.exists(branchName) Then
branchNames.Add branchName
branchDict.Add branchName, 1
End If
Next cell
On Error GoTo 0
End With
' Loop through each branch name to create a new workbook
For Each branchName In branchNames
Set newWorkbook = Workbooks.Add
' Loop through each worksheet to copy relevant data for the branch
For Each ws In originalWorkbook.Worksheets
ws.Copy After:=newWorkbook.Sheets(newWorkbook.Sheets.Count)
Set newSheet = newWorkbook.Sheets(newWorkbook.Sheets.Count)
With newSheet
' Apply filter based on branch name in column C
.UsedRange.AutoFilter Field:=3, Criteria1:=branchName
' Check if there are any visible rows after filtering
On Error Resume Next
Set visibleRange = .UsedRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' If there is data, copy and assign it directly to the new workbook
If Not visibleRange Is Nothing Then
.Cells.Clear ' Clear all data before copying filtered rows
visibleRange.Copy
.Range("A1").Resize(visibleRange.Rows.Count, visibleRange.Columns.Count).Value = visibleRange.Value
Application.CutCopyMode = False
End If
' Remove the filter
If .AutoFilterMode Then
.ShowAllData
End If
End With
Next ws
' Remove default empty worksheet (Sheet1) from the new workbook
Application.DisplayAlerts = False
newWorkbook.Sheets(1).Delete
Application.DisplayAlerts = True
' Save the new workbook with the branch name
newWorkbook.SaveAs originalWorkbook.Path & "" & branchName & ".xlsx"
newWorkbook.Close False
Next branchName
MsgBox "Workbooks have been created for each branch.", vbInformation
End Sub
Bookmarks