Create worksheets conditional on column values VBA

[sofas]

Welcome. I have a worksheet with data consisting of 3 columns from C to E. Column C contains customer contract codes that always include a specific letter at the beginning. What I am looking for is to filter customers according to the first letter of the contract code, column C. And create new worksheets with them in the form shown in the pictures below and name them with the first letter of the code.
Note: This is only a copy of the original file. The data can be expanded, whether in rows or in different contract codes.

Create new sheets Excel.xlsm

Shared with Dropbox

www.dropbox.com

 

[sofas]

I have only been able to test this using an English character set, so try it and let me know how you go with it.

Sub CopyCodeGroupToNewSheet_v02()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, srcCodeArr As Variant
    Dim srcLastRow As Long, srcNextCol As Long
    Dim critRng As Range, destRng As Range
    Dim dictSrc As Object, dictKey As String, vKey As Variant
   
    Dim i As Long
   
    Application.ScreenUpdating = False
   
    ' Initialise and get Next Available Column
    Set srcSht = Worksheets("Data")
    With srcSht
        srcLastRow = .Cells(Rows.Count, "D").End(xlUp).Row
        srcNextCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 2
        Set srcRng = .Range("C1:E" & srcLastRow)
        srcCodeArr = srcRng.Columns(2)
        ' Set up Criteria range
        Set critRng = .Cells(1, srcNextCol)
        critRng.Value = .Range("D1")
        Set critRng = .Cells(1, srcNextCol).Resize(2)
    End With
      
    ' Get unique Code Group - 1st Character of Code
    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
   
    For i = 2 To UBound(srcCodeArr)
        dictKey = Left(srcCodeArr(i, 1), 1)
        If Not dictSrc.exists(dictKey) Then
            dictSrc(dictKey) = ""
        End If
    Next i
   
    ' Additional code to handle and group the character A which can be 4 different unicode characters
    Dim ucodeA As Variant, existsA As Boolean, aCharA() As String, j As Long
   
    ucodeA = Array(1570, 1571, 1573, 1575)
    ReDim aCharA(1 To UBound(ucodeA) + 1)
    For i = 0 To UBound(ucodeA)
        dictKey = ChrW(ucodeA(i))
        If dictSrc.exists(dictKey) Then
            existsA = True
            dictSrc.Remove dictKey
        End If
        j = j + 1
        aCharA(j) = dictKey & "*"
    Next i
   
    If existsA Then
        dictKey = Replace(Join(aCharA, ","), "*", "")
        dictSrc(dictKey) = ""
    End If
   
    ' Loop through IDs and create or update sheet for group (grouped on first letter)
    For Each vKey In dictSrc.keys
        ' Does sheet already exist
        If Evaluate("ISREF('" & vKey & "'!A1)") Then
            Set destSht = Worksheets(vKey)
            destSht.UsedRange.Clear
        Else
            Set destSht = Worksheets.Add(After:=Sheets(Sheets.Count))
            destSht.Name = vKey
        End If
       
        ' Advanced filter
        If Len(vKey) > 1 Then
            critRng.Cells(2).Resize(UBound(aCharA)) = Application.Transpose(aCharA)
            Set critRng = critRng.CurrentRegion
        Else
            critRng.Offset(1).ClearContents
            critRng.Cells(2) = vKey & "*"
            Set critRng = critRng.CurrentRegion
        End If
       
        srcRng.AdvancedFilter xlFilterCopy, critRng, destSht.Range("A1")
        ' Apply source column widths
        srcRng.EntireColumn.Copy
        destSht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    Next vKey

    ' Clean up temporary criteria range
    critRng.EntireColumn.Delete
   
    Application.ScreenUpdating = True
End Sub

Words cannot express the thanks and gratitude I feel for your honorable person. An effort beyond words. Amazing results.
If I could, I would send you bouquets of roses as large as grains of sand. Indeed, you are a genius

 

[Alex Blakenburg]

Thanks for the kind words. Happy to help.