Segregate data into Worksheets
VBA

VBA User form for Segregate data into multiple worksheets

Many times, we require to segregate our data into different worksheets. Here we have created a macro which can segregate your data into worksheets. One user from will be displayed wherein you can select the field name by which you want to segregate your data.

Below is the data which we will segregate into multiple worksheets-

Data
Data

We have added an icon on home tab to run this macro-

Icon
Icon

Below given user form will be displayed after clicking on this icon

User form
User form
  • Select any field and click on run.
  • Data will be segregated into different worksheet-
Segregated data
Segregated data

Below is code of this user form-

Option Explicit

Private Sub CommandButton1_Click()

Application.DisplayAlerts = False

Dim nwb As Workbook
Dim nsh As Worksheet
Dim dsh As Worksheet
Dim support As Worksheet

Set dsh = ActiveSheet

Dim col_number As Integer
Dim i As Integer

col_number = Application.WorksheetFunction.Match(Me.ComboBox1.Value, dsh.Range("1:1"), 0)

Set nwb = Workbooks.Add
Set support = nwb.Sheets(1)

dsh.AutoFilterMode = False
dsh.Cells(1, col_number).EntireColumn.Copy
support.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
support.UsedRange.RemoveDuplicates 1, xlYes

For i = 2 To Application.CountA(support.Range("A:A"))
Set nsh = nwb.Sheets.Add(after:=Sheets(Sheets.Count))
dsh.UsedRange.AutoFilter col_number, VBA.IIf(support.Range("A" & i).NumberFormat = "General", support.Range("A" & i).Value, VBA.Format(support.Range("A" & i).Value, support.Range("A" & i).NumberFormat))
dsh.UsedRange.Copy nsh.Range("A1")
On Error Resume Next
nsh.Name = VBA.IIf(support.Range("A" & i).NumberFormat = "General", support.Range("A" & i).Value, VBA.Format(support.Range("A" & i).Value, support.Range("A" & i).NumberFormat))
On Error GoTo 0

nsh.UsedRange.EntireColumn.ColumnWidth = 25
dsh.AutoFilterMode = False
ActiveWindow.DisplayGridlines = False
Next i

support.Delete

MsgBox "Process Completed"

End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub


Private Sub UserForm_Initialize()

If Application.WorksheetFunction.CountA(ActiveSheet.Range("1:1")) > 0 Then
Dim i As Integer
For i = 1 To Application.WorksheetFunction.CountA(ActiveSheet.Range("1:1"))
If ActiveSheet.Cells(1, i).Value <> "" Then
Me.ComboBox1.AddItem ActiveSheet.Cells(1, i).Value
End If
Next i
End If

End Sub

 

Click here to download the Practice file-

Watch the step by step video tutorial:

PK
My Name is PK. I am founder of PK-AnExcelExpert.com. I am a Microsoft Certified Professional. I have more than 10 years of experience in Data Visualization, Excel Automation and dashboard creation. Excel is my passion and I like to do always something innovative in Excel and share it with other people.
https://www.pk-anexcelexpert.com