I have other macros that are 5 times the size of this one and are still under 1Meg. I don't know why, but this one is saving as 2.88MB

Any ideas why? (fyi: there are also 3 forms with little to no code embedded.)

Public Problems(1 To 22, 2) As String 'Adds Array for Keywords/Phrases
Public Return_Notes As String
Public Number_of_Keywords As Integer
Sub Run_CITE()

Dim DataURL As String
Dim Pro_ID As String
Dim Sku As String
Dim FinalRow As Long
Dim NewString As String
Dim s As Integer
Dim FinalCell As Integer
Dim i As Long
Dim Brain As Brain
Set Brain = New Brain
If Brain.optAllowErrors = False Then
    On Error GoTo ErrorHandler
End If

Application.ScreenUpdating = False

FinalRow = ActiveSheet.Range("A65536").End(xlUp).Row
actionlistbookname = ActiveWorkbook.Name
actionlistsheetname = ActiveSheet.Name


 


FinalRow = ActiveSheet.Range("A65536").End(xlUp).Row




For i = FinalRow To 2 Step -1
DoEvents
Application.StatusBar = "Processing # " & i
FinalCell = ActiveSheet.Range("A" & i).End(xlToRight).Column + 1
DoEvents

Pro_ID = ActiveSheet.Range(Brain.ProductID & i).Text
DataURL = "http://www.urlremovedfromcodeforsecurityreasons"

    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & DataURL & "" _
        , Destination:=Range("A1"))
        .Name = Sku
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
    Info = Range("A1").Text 'Removes the text "Return Reasons for"
    NewString = Trim(Replace(Info, "Return Reasons for", ""))
    Range("A1").FormulaR1C1 = NewString

        For s = 1 To Len(NewString) 'Determines location of Sku within String
        DoEvents
            If Mid(NewString, s, 1) = " " Then
                Marker1 = s - 1
                Exit For
            End If
        Next s
        Sku = Trim(Mid(NewString, 1, Marker1)) 'Extracts Sku
    
    ActiveSheet.Name = Sku
    Call Keywords
    Call Guess
    For v = 2 To 22
        If Val(Problems(v - 1, 2)) > Val(Problems(v, 2)) Then
        DoEvents
            greatestprob = v - 1
        End If
    Next v
    Problems(greatestprob, 0) = 1
    For v = 1 To 22
    DoEvents
        If Problems(v, 0) = "1" Then
            Sheets(actionlistsheetname).Select
            Range(frmCite.txtRR.Text & i).Select
            Range(frmCite.txtRR.Text & i).Value = Problems(v, 1)
                'If Sheets("Sheet1").chkHLnk.Value = True Then
                '    HyperLnk = Range(Brain.Sku & i).Text & "!A1"
                '    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                '    HyperLnk, TextToDisplay:=Problems(v, 1)
                'End If
            Exit For
        End If
    Next v
For v = 1 To 22 ' Reset Results
DoEvents
    Problems(v, 2) = ""
    Problems(v, 0) = ""
Next v
    Application.DisplayAlerts = False
        Sheets(Sku).Delete
    Application.DisplayAlerts = True
Next i
    
'If Sheets("Sheet1").chkNotes.Value = False Then
'    Application.DisplayAlerts = False
'        Sheets(Sku).Delete
'    Application.DisplayAlerts = True
'End If

Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
ErrorHandler:
    frmError.Show (vbModeless)
    If Brain.optResumeOnError = True Then
        Resume Next
    End If
End Sub

Sub Guess()
Dim FinalRow As Long
Dim i As Integer
Dim x As Integer
Dim Brain As Brain
Set Brain = New Brain
If Brain.optAllowErrors = False Then
    On Error GoTo ErrorHandler
End If

Number_of_Keywords = 22

FinalRow = Range("B65536").End(xlUp).Row 'Finds the last row

For i = FinalRow To 2 Step -1  'Searches the Sheet for Keywords/Phrases
'    If Range("A" & i).FormulaR1C1 <> "" Then    'Exits Loop if Invoice is < Specified
'        If Val(Range("A" & i).FormulaR1C1) < frmResults.txtInvoice.Text Then
'            Exit For
'        End If
'    End If
    Return_Notes = Range("B" & i).Value
    For x = 1 To 22     'Check Return Notes for Problems
        If InStr(UCase(Return_Notes), UCase(Problems(x, 1))) Then
            Problems(x, 2) = Val(Problems(x, 2)) + 1
        End If
    Next x
Next i
Exit Sub
ErrorHandler:
    frmError.Show (vbModeless)
    If Brain.optResumeOnError = True Then
        Resume Next
    End If
End Sub
Sub Keywords()
'Set Keywords
'*** DO NOT CHANGE #1 OR #20! ***
Problems(1, 1) = "Item defective or broken when received"
Problems(2, 1) = "I misunderstood the image and/or description"
Problems(3, 1) = "The quality wasn't what I wanted"
Problems(4, 1) = "Received the wrong item" '
Problems(5, 1) = "Item was insufficiently packed for shipment"
Problems(6, 1) = "Package damaged in transit"
Problems(7, 1) = "Changed my mind"
Problems(8, 1) = "No reason"
Problems(9, 1) = "I Made a Mistake"
Problems(10, 1) = "Disappointed with Item"
Problems(11, 1) = "This item didn't fit"
Problems(12, 1) = "Not What I Expected"
Problems(13, 1) = "The color wasn't quite right"
Problems(14, 1) = "Delivered Too Late"
Problems(15, 1) = "Wrong Item Delivered"
Problems(16, 1) = "Size Misrepresented"
Problems(17, 1) = "Item Never Delivered"
Problems(18, 1) = "Item arrived later than promised"

Problems(19, 1) = "Item Broken"
Problems(20, 1) = "Item Defective"

Problems(21, 1) = "Insufficient Packing"
Problems(22, 1) = "Item not as described"

'DIT
'too big / too large
'too small
'MIS-SKU / MIS SKU / MISS SKU / MISS-SKU / MISSKU / MISSSKU

End Sub
Sub CITE_Load()
frmCite.Show (vbModeless)
End Sub
Class Modual
I also have a class modual attached that it only 2 pages long.