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

 

[Alex Blakenburg]

See if this works for you.
Note: If any of the Group sheets already exist it will clear them, so you might want to run it on a copy of your workbook.

Sub CopyCodeGroupToNewSheet()

    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
    
    ' Loop through IDs and create or update sheet for group
    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
        critRng.Cells(2) = vKey & "*"
        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

 

[sofas]

See if this works for you.
Note: If any of the Group sheets already exist it will clear them, so you might want to run it on a copy of your workbook.

Sub CopyCodeGroupToNewSheet()

    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
   
    ' Loop through IDs and create or update sheet for group
    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
        critRng.Cells(2) = vKey & "*"
        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

Works like a charm thank you very much. Great work, genius

 

[Alex Blakenburg]

That was quick . You're welcome.

 

[sofas]

Hello Alex. Please, I have one last question. I tried your code and it works very well, better than I expected. But I face a slight problem because I use the Arabic language in the file, which is that the contract names begin with Arabic letters. . There is only one letter, which is the letter A. It can be written in the following form: أ or إ or آ or ا . It is possible to identify it and combine it into one piece of sheet

 

[Alex Blakenburg]

I am a bit confused about the "There is only one letter", I did some research and it looks like all 28 letters have 4 forms.
If that is the case we are going to need a mapping table of each character and how it needs to be grouped.
Its likely that we will need to use the Unicode ie =Unicode(Left(D2,1))

It might be something like this:

20240507 VBA Create new sheets Excel Sofas.xlsm
	A	B	C	D
1	Character	UniCode	Character to use for grouping	Grouping Unicode
2	أ	1571	أ	1571
3	إ	1573	أ	1571
4	آ	1570	أ	1571
5	ا	1575	أ	1571
Character Set

Cell Formulas
Range	Formula
B2:B5,D2:D5	B2	=UNICODE(A2)

 

[sofas]

Yes, your words are correct, but for me, the letter A is perhaps the only one that can create a difference due to the keyboard that writes (ا) as a default letter, so the keyboard must be changed to get an أ or إ for example.
I thought of a solution that might be a bit stupid. But perhaps it meets the offer, and after executing the code, we add another code to merge all the sheets that start with ( ا ) for example, into one sheet

 

[Alex Blakenburg]

If you are pretty sure that is the only letter with multiple cases, I will have a look at handling it in the code.

 

[sofas]

I

If you are pretty sure that is the only letter with multiple cases, I will have a look at handling it in the code.

Thank you for waiting

 

[Alex Blakenburg]

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