Excel VBA - Split Sheets of Saved excel Files

[Firan]

I need some help with excel VBA code,

I have split a file into separate files based on a column (Country) using the below VBA code. This produces around 40 separate files,

Country	Category	Data
Australia	1	454
Australia	3	29
Costa Rica	2	566
Tanzania	3	22
United Kingdom	1	16

Produces:

Australia.xslx

Costa Rica.xslx

Tanzania.xslx

United Kingdom.xslx


Is there a way to then split each of the files by another column (with row entries 1,2,3), so that each file has three sheets without having to open each file and running a macro for each file?



VBA - Split Sheet

Sub Split_Sheet()

Const FirstC As String = "A" '1st column

Const LastC As String = "C" 'last column

Const sCol As String = "A" '<<< Column to Split data by

Const shN As String = "Countries" '<<< Source Sheet

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets(shN)

Dim rng As Range

Dim r As Long, c As Long, x As Long, r1 As Long

Application.ScreenUpdating = False

r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row



 c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2



Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))



ws.Range(sCol & ":" & sCol).Copy

ws.Cells(1, c).PasteSpecial xlValues



Application.CutCopyMode = False

ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes

r1 = ws.Cells(Rows.Count, c).End(xlUp).Row

ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes

ws.AutoFilterMode = False

Application.DisplayAlerts = False

For x = 2 To r1

For Each ws1 In Sheets

If ws1.Name = ws.Cells(x, c) Then ws1.Delete

Next

Next

Application.DisplayAlerts = True

For x = 2 To r1

ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)

Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))

ws1.Name = ws.Cells(x, c).Value

rng.SpecialCells(xlCellTypeVisible).Copy

Range("A1").PasteSpecial Paste:=xlPasteFormats

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

Range("A1").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

Next x

With ws

.AutoFilterMode = False

.Cells(1, c).Resize(r).ClearContents

.Activate

.Range("A1").Select

End With

Application.ScreenUpdating = True

End Sub

VBA - Save Each File

Sub SaveEachWorksheet()



Dim FPath As String



FPath = Application.ActiveWorkbook.Path



Application.ScreenUpdating = False



Application.DisplayAlerts = False



For Each ws In ThisWorkbook.Sheets



    ws.Copy



    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\"ws.Name & ".xlsx"



    Application.ActiveWorkbook.Close False



Next



Application.DisplayAlerts = True



Application.ScreenUpdating = True



End Sub

 

[bukimi]

Why not use a macro that opens all files in a specified folder one by one?

Example from excelhowto webpage:

Sub OpenAllWorkbooks()
'Step 1:Declare your variables
    Dim MyFiles As String
'Step 2: Specify a target folder/directory, you may change it.
    MyFiles = Dir("d:\Temp\*.xlsx")
    Do While MyFiles <> ""
'Step 3: Open Workbooks one by one
    Workbooks.Open "d:\Temp\" & MyFiles

    'run some code here
    MsgBox ActiveWorkbook.Name

    ActiveWorkbook.Close SaveChanges:=True

'Step 4: Next File in the folder/Directory
    MyFiles = Dir
    Loop
End Sub

You have "run some code here" which should be replaceable by "Call" and your split macro name.

 

[Fluff]

Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Excel VBA - Split Sheets of Saved excel Files
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.