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
Excel VBA Macros for Non-Coders

Do you find VBA Macros scary? Did you miss any job opportunity because of it? Get started today with our eBook guide on using – Excel VBA Macros. 140 pages of rich visuals. Download now.
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
Excel VBA Macros for Non-Coders

Do you find VBA Macros scary? Did you miss any job opportunity because of it? Get started today with our eBook guide on using – Excel VBA Macros. 140 pages of rich visuals. Download now.