bulknpcgen.vb

Option Explicit
Public Sub BulkNPCGen()
    Dim NPCs, i, j As Integer
    
    Dim Dum As String
    
    Dim WrkN As String
    Dim NPCLim As Integer
    
    Dim Race, PresetRace, Gender As String
    
    Dim Export() As Variant
    Dim NPC, N As String
    
    'definitions
    WrkN = "Bulk NPCs"
    NPCLim = 50
    
    j = 0
    Do
        j = j + 1
        If j = 1 Then
            NPCs = InputBox("This will create a new sheet and populate with a number of NPCs matching the race that you have entered between 1 and " & NPCLim & ". If you did not enter a race the races will be randomly chosen.", "Input Required")
        Else
            NPCs = InputBox("This will create a new sheet and populate with a number of NPCs matching the race that you have entered between 1 and " & NPCLim & ". If you did not enter a race the races will be randomly chosen.", "Invalid entry, please try again")
        End If
        
        If NPCs = "" Then
            End
        Else
            NPCs = Round(NPCs, 0)
        End If
    Loop Until j > 1000 Or IsNumeric(NPCs) = True And NPCs < NPCLim + 1 And NPCs > 0
    
    'redim export array
    ReDim Export(1 To NPCs, 1 To 4) As Variant
    
    'check existing output
    If WorksheetExists(WrkN) = True Then
        Dum = MsgBox("Overwrite previous bulk generation?", vbYesNo, "Overwite?")
        
        If Dum = vbNo Then
            Dum = InputBox("Please enter a new name for the previous bulk generation", "Rename")
            
            Application.ScreenUpdating = False
            
            If Dum = "" Then Exit Sub
            
            If WorksheetExists(Dum) = True Then GoTo ERRHNDLR
            
            Sheets(WrkN).ListObjects("BulkNPCTable").Name = "OldBulkNPCTable"
            Sheets(WrkN).Name = Dum
        Else
            Sheets(WrkN).Delete
            If WorksheetExists(WrkN) = True Then Exit Sub
            Application.ScreenUpdating = False
        End If
    End If
    
    'prep new sheet
    Sheets.Add After:=ActiveSheet
    
    With ActiveSheet
        .Name = "Bulk NPCs"
        .Range("A1").Value = "Name"
        .Range("B1").Value = "Race"
        .Range("C1").Value = "Gender"
        .Range("D1").Value = "Description"
        .ListObjects.Add(xlSrcRange, Range("$A$1:D" & NPCs + 1), , xlYes).Name = "BulkNPCTable"
    End With
    
    'populate array
    PresetRace = Sheets("NPC Generator").Range("NPCRace").Value
    For i = 1 To NPCs
        Race = PresetRace
        NPC = ""
        N = ""
        Gender = ""
        
        Call GenerateNPC(, Race, Gender, , , , N, , True, NPC)
        
        Export(i, 1) = N
        Export(i, 2) = Race
        Export(i, 3) = Gender
        Export(i, 4) = NPC
    Next
    
    'populate table
    ActiveSheet.Range("BulkNPCTable").Value = Export()
    
    Dum = MsgBox("There may be NPCs in this generation that share the same name. Would you like to automatically remove" _
        & "duplicates? This may result in generating fewer NPCs than you had specified. More duplicates occur in races with a shorter name table to pull from.", vbYesNo, "Automatically Remove Duplicates?")
    
    If Dum = vbYes Then
        ActiveSheet.Range("BulkNPCTable[#All]").RemoveDuplicates Columns:=1, Header:=xlYes
    End If
    
    Cells.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15921906
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Color = -13683110
        .TintAndShade = 0
    End With
    
    With ActiveSheet
        .Range("BulkNPCTable[#All]").ClearFormats
        .ListObjects("BulkNPCTable").TableStyle = "D&D Table 2"
    End With
    
    'fix cs and rs
    Columns("A:C").EntireColumn.AutoFit
    Columns("D:D").Select
    Selection.ColumnWidth = 70.57
    Cells.Select
    Cells.EntireRow.AutoFit
    
    Columns("A:C").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("D:D").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    'sort
    Range("A2").Select
    ActiveWorkbook.Worksheets("Bulk NPCs").ListObjects("BulkNPCTable").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Bulk NPCs").ListObjects("BulkNPCTable").Sort. _
        SortFields.Add Key:=Range("BulkNPCTable[[#All],[Name]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Bulk NPCs").ListObjects("BulkNPCTable").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'set
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
    'end of main code
    Exit Sub
ERRHNDLR:
    Dum = Dum
End Sub