Tab creation failure using macro

Question

I needed to work with a huge Excel file, but utilising VBA presented some challenges.

There are 53 columns across all 28 tabs in this excel document. Some years have more people on the tabs that are about the years. Both the first column's subject, Person system ID, and the second column's subject, his name, are all capitalised.

I attempted to use Chat GPT to construct a VBA code that would map every tab and create a separate tab for every distinct name and save, but I encountered some errors.

Here is the code that chat GPT wrote:

Function IsInArray(arr, val) As Boolean
    Dim found As Boolean
    found = False
    
    If IsArray(arr) And Not IsEmpty(arr) Then
        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            If arr(i) = val Then
                found = True
                Exit For
            End If
        Next i
    End If
    
    IsInArray = found
End Function

Sub Create_Individual_Sheets()
    Dim SheetName As String
    Dim NameList() As String
    Dim LastRow As Long
    Dim Year As Integer
    Dim Sheet As Worksheet
    Dim NewSheet As Worksheet
    Dim Name As Variant
    Dim i As Long
    Dim Folder As String
    
    Folder = "C:\Users\Jorjao\Desktop\Folder"
    
    For Year = 1994 To 2022
        Set Sheet = Worksheets(CStr(Year))
        LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
        
        'loop through the name column in the current sheet and add to the name list
        For i = 2 To LastRow
            Name = UCase(Sheet.Cells(i, 2).Value)
            If Not IsInArray(NameList, Name) Then
                ReDim Preserve NameList(UBound(NameList) + 1)
                NameList(UBound(NameList)) = Name
            End If
        Next i
    Next Year
    
    'loop through the name list and create an individual sheet for each name
    For Each Name In NameList
        Set NewSheet = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
        SheetName = Replace(Name, " ", "_")
        NewSheet.Name = SheetName
        
        'loop through each sheet and copy the rows with the current name to the individual sheet
        For Year = 1994 To 2022
            Set Sheet = Worksheets(CStr(Year))
            LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
            
            'loop through the name column in the current sheet and check if the current name is present
            For i = 2 To LastRow
                If UCase(Sheet.Cells(i, 2).Value) = Name Then
                    Sheet.Rows(i).Copy Destination:=NewSheet.Rows(NewSheet.Cells(Rows.Count, 1).End(xlUp).Row.Offset(1))
                End If
            Next i
        Next Year
        
        'save the new sheet in a folder
        NewSheet.Copy
        ActiveWorkbook.SaveAs Filename:=Folder & SheetName & ".xlsx"
        ActiveWorkbook.Close savechanges:=False
    Next Name
End Sub

Using this code, I got:

Runtime error 9

Subscript out of range

I also tried to change somethings, but I also got some runtime error like 13 and 424.

Answer 1

Export By Name From Multiple Worksheets

Option Explicit

Sub ExportByName()
    Const PROC_TITLE As String = "Export By Name"
    ' Log issues using a dictionary.
    Dim eDict As Object: Set eDict = CreateObject("Scripting.Dictionary")
    Dim Success As Boolean ' different message boxes
    On Error GoTo ClearError ' start an error-handling routine
    
    ' Define constants.
    
    Const NAMES_COLUMN As Long = 2
    Const DST_USER_SUBFOLDER As String = "\Desktop\Folder\"
    
    Dim swsNames(): swsNames = VBA.Array( _
        "1994", "1995", "1996", "1997", "1998", "1999", "2000", "2001", _
        "2002", "2003", "2004", "2005", "2006", "2007", "2008", "2009", _
        "2010", "2011", "2012", "2013", "2014", "2015", "2016", "2017", _
        "2018", "2019", "2020", "2021", "2022")
    
    ' Write the data of each worksheet to an array held by a jagged array.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    Dim sCount As Long: sCount = UBound(swsNames) + 1
    Dim sJag(): ReDim sJag(1 To sCount)
    
    Dim sws As Worksheet, stws As Worksheet, sData, sn As Long, sName As String
    Dim rCount As Long, scCount As Long, IsFirstFound As Boolean
    Dim snCount As Long, srCount As Long, cCount As Long
    
    For sn = 1 To sCount
        sName = swsNames(sn - 1)
        On Error Resume Next ' prevent error if worksheet doesn't exist
            Set sws = swb.Worksheets(sName)
        On Error GoTo ClearError ' continue with the error-handling routine
        If Not sws Is Nothing Then ' worksheet exists
            With sws.Range("A1").CurrentRegion
                rCount = .Rows.Count - 1
                scCount = .Columns.Count
                If rCount = 0 Then
                    eDict(sName) = "No data in worksheet." ' log
                Else
                    sData = .Resize(.Rows.Count - 1).Offset(1).Value
                    snCount = snCount + 1
                    sJag(snCount) = sData
                    srCount = srCount + rCount
                    If scCount > cCount Then
                        cCount = scCount
                        ' The first worksheet with the most columns
                        ' will be used as a template,
                        Set stws = sws
                        If IsFirstFound Then
                            eDict(sName) = "Has " & cCount & " columns." ' log
                        End If
                    End If
                    If Not IsFirstFound Then IsFirstFound = True
                End If
            End With
            Set sws = Nothing
        Else ' worksheet doesn't exist
            eDict(sName) = "Worksheet not found." ' log
        End If
    Next sn
    
    If Not IsFirstFound Then GoTo ProcExit
    
    ' Write the data from the jagged array to a 2D one-based array.
    
    ReDim sData(1 To srCount, 1 To cCount)
    
    Dim nr As Long, sr As Long, sc As Long
    
    For sn = 1 To snCount
        For sr = 1 To UBound(sJag(sn), 1)
            nr = nr + 1
            For sc = 1 To UBound(sJag(sn), 2)
                sData(nr, sc) = sJag(sn)(sr, sc)
            Next sc
        Next sr
    Next sn
    
    Erase sJag ' data is in 'sData'
    
    ' Write the unique names (from the array) and the rows of their appearances
    ' to a dictionary: the names to its 'keys' and the rows to collections
    ' held by the 'its' items.
    
    Dim nDict As Object: Set nDict = CreateObject("Scripting.Dictionary")
    nDict.CompareMode = vbTextCompare
    
    Dim sStr As String
    
    For sr = 1 To srCount
        sStr = CStr(sData(sr, NAMES_COLUMN))
        If Not nDict.Exists(sStr) Then Set nDict(sStr) = New Collection
        nDict(sStr).Add sr
    Next sr
    
    ' Using the array and the information in the dictionary,
    ' write the rows of each name to a 2D one-based array held
    ' by a jagged array.
    
    Dim dnCount As Long: dnCount = nDict.Count
    
    Dim dJag(): ReDim dJag(1 To dnCount)
    Dim dNames() As String: ReDim dNames(1 To dnCount)
    
    Dim dData(), nKey, nItem, drCount As Long, dr As Long, dn As Long
    
    For Each nKey In nDict.Keys
        drCount = nDict(nKey).Count
        ReDim dData(1 To drCount, 1 To cCount)
        For Each nItem In nDict(nKey)
            dr = dr + 1
            sr = nItem
            For sc = 1 To cCount
                dData(dr, sc) = sData(sr, sc)
            Next sc
        Next nItem
        dn = dn + 1
        dJag(dn) = dData
        dNames(dn) = nKey
        dr = 0
    Next nKey
    
    Set nDict = Nothing
    Erase sData
    Erase dData
    
    ' Create the template workbook: clear all data below the 2nd row
    ' and clear contents in the first row which will be used
    ' to copy the formatting.
    
    Application.ScreenUpdating = False
    
    stws.Copy
    
    Dim twb As Workbook: Set twb = Workbooks(Workbooks.Count)
    Dim tws As Worksheet: Set tws = twb.Worksheets(1)
    
    Dim trCount As Long: trCount = tws.Rows.Count - 2
    
    With tws.Range("A1").CurrentRegion
        If trCount > 0 Then
                .Resize(trCount).Offset(2).Clear
        End If
        .Rows(2).ClearContents
    End With
        
    ' For each array in the jagged array, copy the template worksheet
    ' to a new workbook, copy the formatting from the first row,
    ' copy the data from the array and save and close it.
    ' Finally, close the template workbook.
    
    Dim dPath As String: dPath = Environ("USERPROFILE") & DST_USER_SUBFOLDER
    'Dim dPath As String: dPath = "C:\Test\"
    
    Dim dwb As Workbook, dws As Worksheet, dFilePath As String, dName As String
    
    For dn = 1 To dnCount
        drCount = UBound(dJag(dn), 1)
        dName = dNames(dn)
        dFilePath = dPath & dName
        
        tws.Copy ' template to new worksheet
        
        Set dwb = Workbooks(Workbooks.Count)
        Set dws = dwb.Worksheets(1)
        dws.Name = dName
        
        With dws.Range("A2").Resize(drCount, cCount)
            .Rows(1).Copy .Resize(drCount - 1).Offset(1) ' copy formatting
            .Value = dJag(dn) ' copy values
        End With
        
        Application.DisplayAlerts = False ' overwrite without confirmation
            dwb.SaveAs dFilePath
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next dn
            
    twb.Close SaveChanges:=False
            
    Success = True
            
    Application.ScreenUpdating = True
            
    ' Inform.
            
ProcExit: ' start exit routine
    On Error Resume Next ' prevent endless loop if error in continuation
    
        Dim mStr As String
        If Not Success Then mStr = "Something went wrong." & vbLf & vbLf
        mStr = mStr & dn & " worksheet" & IIf(dn = 1, "", "s") & " exported."
        
        If eDict.Count > 0 Then
            mStr = mStr & vbLf & vbLf & "Found the following issues:" & vbLf
            For Each nKey In eDict.Keys
                mStr = mStr & vbLf & nKey & vbTab & eDict(nKey)
            Next nKey
        End If
                
        MsgBox mStr, IIf(Success, vbInformation, vbCritical), PROC_TITLE

    On Error GoTo 0
    Exit Sub
ClearError: ' continue with the error-handling routine.
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit ' redirects toward the exit routine
End Sub