Create Type-Specific Worksheets in Excel using VBA
Description
-
This is a VBA code for creating type-specific worksheets in Excel based on a unique column value in a source worksheet.
-
The code first defines constants for the source worksheet name and the column that contains the unique values. It then sets up variables for the workbook, source worksheet, source data range, and a dictionary object for grouping data by unique values.
-
The code then loops through the source data, adds each unique value to the dictionary, and adds the corresponding row numbers to a collection within the dictionary.
-
The code then creates a new worksheet as a template for the type-specific worksheets and clears any existing data. It then loops through the dictionary, creating a new worksheet for each unique value and copying the rows from the source data that correspond to that value.
-
If a worksheet with the same name already exists, the code deletes it first to avoid conflicts. Once all the type-specific worksheets have been created, the template worksheet is deleted.
-
Finally, the code displays a message box to inform the user that the process is complete.
The Code
Sub CreateTypeWorksheets()
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const UNIQUE_COLUMN As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the source data to an array.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range, srCount As Long, cCount As Long
With sws.Range("A1").CurrentRegion
srCount = .Rows.Count - 1
cCount = .Columns.Count
Set srg = .Resize(srCount).Offset(1)
End With
Dim sData(): sData = srg.Value
' Populate a dictionary with the unique types
' and their corresponding row numbers.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sr As Long, sStr As String
For sr = 1 To srCount
sStr = CStr(sData(sr, UNIQUE_COLUMN))
If Not dict.Exists(sStr) Then Set dict(sStr) = New Collection
dict(sStr).Add sr
Next sr
' Create the template worksheet.
Application.ScreenUpdating = False
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Dim tws As Worksheet: Set tws = wb.Sheets(wb.Sheets.Count)
With tws.Range("A1").CurrentRegion
.Resize(srCount).Offset(1).Clear
End With
' Create the type-specific worksheets.
Dim dsh As Object, dData(), Key, rItem, dr As Long, c As Long
For Each Key In dict.Keys
' Write to an array.
ReDim dData(1 To dict(Key).Count, 1 To cCount)
For Each rItem In dict(Key)
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(rItem, c)
Next c
Next rItem
' Delete existing worksheet.
On Error Resume Next
Set dsh = wb.Sheets(Key)
On Error GoTo 0
If Not dsh Is Nothing Then
Application.DisplayAlerts = False ' delete without confirmation
dsh.Delete
Application.DisplayAlerts = True
Set dsh = Nothing ' reset for the next iteration
End If
' Create the worksheet.
tws.Copy After:=wb.Sheets(wb.Sheets.Count)
' Copy data from the array.
With wb.Sheets(wb.Sheets.Count)
.Name = Key
.Range("A2").Resize(dr, cCount).Value = dData
End With
dr = 0 ' reset for the next iteration
Next Key
' Delete the template worksheet.
Application.DisplayAlerts = False ' delete without confirmation
tws.Delete
Application.DisplayAlerts = True
' Inform.
Application.ScreenUpdating = True
MsgBox "Type worksheets created.", vbInformation
End Sub
