VBA – Split worksheet to worksheets, save Excel worksheets to csv

Posted on May 31, 2022 by

Same article, but for Python is here – https://www.vitoshacademy.com/python-split-worksheet-to-worksheets-save-excel-worksheets-to-csv/

This article does 2 things:

Splits one worksheet to multiple worksheets
Then goes through the worksheets and saves them as *.CSV files

I hope that is enough for you.

#RandomMountain

Ok, so we start with the following Excel file like this:

Make sure to declare the worksheet with the inital data here correspondingly – Public Const WKS_TO_KEEP As String = "Tabelle1". In my case, it is "Tabelle1".

And the idea is to split this main worksheet into multiple other worksheets, keeping the title [Alpha, Bravo, Charlie, Delta] and starting each fifth row on a new worksheet. Like this:

The first worksheet with name 1 contains the values from the first 5 rows. This is the second, it is named 6 and it contains the next 5 values, from row 6 to row 10.

The fifth row is optional, of course. The interesting part is that we got all the data split into new worksheets. Then, the last step is to create a separate CSV file from each of those worksheets:

“CSV_FILE” comes from Public Const CSV_NAME As String = "CSV_FILE"

This is pretty much all. The code to get this done is below:

Option Explicit

Public Const CSV_NAME As String = "CSV_FILE"
Public Const MY_STEP As Long = 5
Public Const WKS_TO_KEEP As String = "Tabelle1"
'

Function WksToKeep() As Worksheet

    Set WksToKeep = ThisWorkbook.Worksheets(WKS_TO_KEEP)

End Function

Sub SplitMe()
       
    OnStart
   
    Dim myLastRow As Long: myLastRow = LastRow(WksToKeep)
    Dim myCell As Range, i As Long
    
    For i = 1 To myLastRow Step MY_STEP
    
        With WksToKeep
        
            Dim newWks As Worksheet
            Set newWks = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newWks.Name = i
            newWks.Rows(1).Value = .Rows(1).Value
            
            Dim ii As Long
            For ii = 2 To MY_STEP + 1
               
                With newWks
                    newWks.Rows(ii).Value = WksToKeep.Rows(i + ii - 1).Value
                End With

            Next
        End With
    Next
    
    OnEnd
   
End Sub

Public Sub DeleteAllButOne()
       
    Dim wks As Worksheet
    OnStart
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name <> WKS_TO_KEEP Then
            wks.Delete
        End If
    Next wks
    OnEnd

End Sub

Public Sub MakeMeACSV()
   
    Dim myNewWorkbook As Workbook
    OnStart
   
    Dim myWorksheet As Worksheet
    For Each myWorksheet In ThisWorkbook.Worksheets
        If myWorksheet.Name <> WKS_TO_KEEP Then
            
            Set myNewWorkbook = Workbooks.Add
            myWorksheet.Copy myNewWorkbook.Sheets(1)
            
            myNewWorkbook.Worksheets(WKS_TO_KEEP).Delete
           
            Dim myFileName As String
            myFileName = ThisWorkbook.Path & "\"
            myFileName = myFileName & CSV_NAME & Format(Date, "YYYYMMDD") & "_" & Format(Now(), "hhnnss") & ".csv"
           
            myNewWorkbook.Worksheets(1).Columns(1).Delete
           
            If myNewWorkbook.Worksheets(1).Cells(2, 1).Value = "" Then
                myNewWorkbook.Worksheets(1).Rows(1).Delete
            End If
           
            Debug.Print myNewWorkbook.Path
            myNewWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlCSV, local:=True
            myNewWorkbook.Close False
           
        End If
    Next
   
    OnEnd
End Sub

Sub Main()

    SplitMe
    MakeMeACSV
   
End Sub

Public Sub OnStart()
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic
    Application.EnableEvents = False

End Sub

Public Sub OnEnd()
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
   
End Sub

Public Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long

    LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column
    
End Function

Public Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long
    
    LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

Option Explicit

Public Const CSV_NAME As String = "CSV_FILE"

Public Const MY_STEP As Long = 5

Public Const WKS_TO_KEEP As String = "Tabelle1"

Function WksToKeep() As Worksheet

Set WksToKeep = ThisWorkbook.Worksheets(WKS_TO_KEEP)

End Function

Sub SplitMe()

OnStart

Dim myLastRow As Long: myLastRow = LastRow(WksToKeep)

Dim myCell As Range, i As Long

For i = 1 To myLastRow Step MY_STEP

With WksToKeep

Dim newWks As Worksheet

Set newWks = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

newWks.Name = i

newWks.Rows(1).Value = .Rows(1).Value

Dim ii As Long

For ii = 2 To MY_STEP + 1

With newWks

newWks.Rows(ii).Value = WksToKeep.Rows(i + ii - 1).Value

End With

OnEnd

End Sub

Public Sub DeleteAllButOne()

Dim wks As Worksheet

OnStart

For Each wks In ThisWorkbook.Worksheets

If wks.Name <> WKS_TO_KEEP Then

wks.Delete

End If

Next wks

OnEnd

End Sub

Public Sub MakeMeACSV()

Dim myNewWorkbook As Workbook

OnStart

Dim myWorksheet As Worksheet

For Each myWorksheet In ThisWorkbook.Worksheets

If myWorksheet.Name <> WKS_TO_KEEP Then

Set myNewWorkbook = Workbooks.Add

myWorksheet.Copy myNewWorkbook.Sheets(1)

myNewWorkbook.Worksheets(WKS_TO_KEEP).Delete

Dim myFileName As String

myFileName = ThisWorkbook.Path & "\"

myFileName = myFileName & CSV_NAME & Format(Date, "YYYYMMDD") & "_" & Format(Now(), "hhnnss") & ".csv"

myNewWorkbook.Worksheets(1).Columns(1).Delete

If myNewWorkbook.Worksheets(1).Cells(2, 1).Value = "" Then

myNewWorkbook.Worksheets(1).Rows(1).Delete

End If

Debug.Print myNewWorkbook.Path

myNewWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlCSV, local:=True

myNewWorkbook.Close False

End If

OnEnd

End Sub

Sub Main()

SplitMe

MakeMeACSV

End Sub

Public Sub OnStart()

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.Calculation = xlAutomatic

Application.EnableEvents = False

End Sub

Public Sub OnEnd()

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.StatusBar = False

End Sub

Public Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long

LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column

End Function

Public Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long

LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row

End Function

What is worth mentioning is the following:

To run the first step, run SplitMe() , for the second step run MakeMeACSV().
- The CSV files are made in the folder of the Excel file, in which the code resides.
The constants on the top of the code are actually rather important:
- Make sure that you have a worksheet named “Tabelle1” or it will not work.
- Furthermore “Tabelle1” is the worksheet, that should contain the initial data, to be splitted.
If you make a mistake, use DeleteAllButOne(), which will delete all worksheets, but the one declared with this one – WKS_TO_KEEP.
In my code, I am deleting the first column in the CSV file (Alpha), because I do not need it.
- Just comment out this line – myNewWorkbook.Worksheets(1).Columns(1).Delete , if you want to keep it.

That’s all! I have even added this one to my boilerplate!

Tagged with: save worksheets to csv, split worksheet to worksheets, VBA, workbook to csv

VBA – Split worksheet to worksheets, save Excel worksheets to csv

Related posts: