NEW! FREE 1 hour Data Cleaning Course for Beginner Users Watch now 

ExcelExcel VBA Code

VBA Code to Split table by Columns

3 Mins read

Step 1: Press the Shortcut keys Alt + F11 to open the Visual Basic for Application window.

Step 2: In the Visual Basic for Applications window, Click Insert > Module, then Copy the below VBA code into the code window.

Sub SplitDataInSheets()
'Created by Yoda Learning Academy
'This VBA code will split the data-table of the given sheet into
'separate worksheets for each given filter element.
'
Const strTempSheet As String = "QQ_Temp"

Dim strMainSheet As String
Dim strFiltColm As String, strFiltRng As String, strDataCol As String
Dim objDataSheet As Worksheet
Dim objTempSheet As Worksheet
Dim lngStartRow As Long, lngLastRow As Long
Dim lngTempRow As Long, lngLastTempRow As Long
Dim strFilterBy As String


Dim strMsgText As String
    
    Application.ScreenUpdating = False
    
    strMainSheet = InputBox("Name of the Data Sheet: ", "Enter Data Sheet Name")
    
    If CheckSheet(strMainSheet) = False Then
        MsgBox "Sheet not found!", vbCritical + vbOKOnly, "Invalid Sheet"
        Exit Sub
    End If
    
    strFiltColm = InputBox("Filter by column: ", "Specify Filter Column")
    
    strDataCol = GetDataCol(strMainSheet, strFiltColm, lngStartRow)
    If strDataCol = "#N/A" Then
        MsgBox "Column not found!", vbCritical + vbOKOnly, "Invalid Column"
        Exit Sub
    End If
    
    lngStartRow = InputBox("Header Row Number:", "Specify Data Starting Row")
    
    Set objDataSheet = ThisWorkbook.Sheets(strMainSheet)
    lngLastRow = objDataSheet.UsedRange.Rows.Count
    strFiltRng = VBA.UCase(strDataCol) & lngStartRow & ":" & VBA.UCase(strDataCol) & lngLastRow
    
    Set objTempSheet = Sheets.Add(After:=objDataSheet)
    objTempSheet.Name = strTempSheet
    
    objTempSheet.Range("A1:A" & lngLastRow).Value = objDataSheet.Range(strFiltRng).Value
    
    objTempSheet.Range("A1:A" & lngLastRow).AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=Range("D1"), Unique:=True
    objTempSheet.Columns("A:C").Delete Shift:=xlToLeft
    ThisWorkbook.Save
    
    lngLastTempRow = objTempSheet.UsedRange.Rows.Count
    
    With objTempSheet
        objDataSheet.UsedRange.AutoFilter
        
        strMsgText = "Congratulations!" & vbNewLine & "The data-table has been split into the following sheets:" & vbNewLine & vbNewLine
        
        For lngTempRow = 2 To lngLastTempRow
            strFilterBy = .Cells(lngTempRow, 1).Value
            
            AddSheet strFilterBy
            
            objDataSheet.Activate
            objDataSheet.UsedRange.AutoFilter Field:=lngColSeq, Criteria1:=strFilterBy
            objDataSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
            
            ThisWorkbook.Sheets(strFilterBy).Activate
            ThisWorkbook.Sheets(strFilterBy).Range("A1").PasteSpecial _
                Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            
            ActiveSheet.Paste
            ActiveSheet.Range("A1").Select
            Application.ScreenUpdating = True
            DoEvents
            Application.ScreenUpdating = False
            DoEvents
            objTempSheet.Activate
            
            strMsgText = strMsgText & strFilterBy & vbNewLine
        Next
    End With
    
    Application.DisplayAlerts = False
    objTempSheet.Delete
    Application.DisplayAlerts = True
    
    objDataSheet.UsedRange.AutoFilter
    Application.ScreenUpdating = True
    objDataSheet.Activate
    objDataSheet.Range("A1").Select
    
    MsgBox strMsgText, vbInformation + vbOKOnly, "Data Split Complete"
    ThisWorkbook.Save
End Sub

After Pasting the above code then Paste the below code for getting the Column letter.

Function GetDataCol(strSheet As String, strField As String, lngRow As Long) As String
'This function will return the column letter respective to the given field.
'
Dim objSheet As Worksheet
Dim iCol As Long
Dim iLastCol As Long
Dim strTmpAdrs As String

    Set objSheet = ThisWorkbook.Sheets(strSheet)
    
    GetDataCol = "#N/A"
    
    With objSheet
        iLastCol = .UsedRange.Columns.Count
        
        For iCol = 1 To iLastCol
            If VBA.UCase(.Cells(1, iCol).Value) = VBA.UCase(strField) Then
                strTmpAdrs = .Cells(1, iCol).Address
                strTmpAdrs = VBA.Replace(strTmpAdrs, "$", "")
                strTmpAdrs = VBA.Replace(strTmpAdrs, "1", "")
                GetDataCol = strTmpAdrs
                lngColSeq = iCol
                Exit For
            End If
        Next
    End With
End Function

After Pasting the above code then Paste the below code for Adding New Sheet

Function AddSheet(strSht As String)
'This function will check the sheet for each unique value of the filter column
'and will add new sheet after deleting if the sheet exists
'
'
Dim iSheetCount As Long
Dim objSht As Worksheet
    
    iSheetCount = ThisWorkbook.Sheets.Count
    Application.DisplayAlerts = False
    For Each objSht In ThisWorkbook.Sheets
        If objSht.Name = strSht Then
            ThisWorkbook.Sheets(objSht.Name).Delete
            iSheetCount = iSheetCount - 1
            Exit For
        End If
    Next objSht
    ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(iSheetCount)
    ThisWorkbook.Sheets(iSheetCount + 1).Name = strSht
    Application.DisplayAlerts = True
End Function

After Pasting the above code then Paste the below code to check the existing sheet according to the parameter

Function CheckSheet(strSht As String) As Boolean
'This function will check whether the given sheet exists or not
'
Dim objSht As Worksheet
    CheckSheet = False
    For Each objSht In ThisWorkbook.Sheets
        If VBA.UCase(objSht.Name) = VBA.UCase(strSht) Then
            CheckSheet = True
            Exit For
        End If
    Next objSht
End Function

Step 3: To Run the Code Go to Developer Tab Click on Macros then you will find “SplitTableinSheets” Code. Click on Run Button

Related posts
Excel VBA Code

VBA Code to Clean the Date Format

1 Mins read
When it is useful? Most of the time the most annoying problem is when the data is taken from ERP or other…
ExcelExcel VBA Code

Create A Table Of Contents By VBA Code

1 Mins read
Step 1: Press the Shortcut keys Alt + F11 to open the Visual Basic for Application window. Step 2: In the Visual…
ExcelExcel VBA Code

Save Each Worksheet as a Separate PDF

1 Mins read
Step 1: Press the Shortcut keys Alt + F11 to open the Visual Basic for Application window. Step 2: In the Visual…