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.