MS Access Union Query Changes Numeric values to Text values

Sub TRANSFORM()

Dim AR() As Variant: AR = Range(Cells(1, 1), Cells(ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column)).Value
Dim HeadCount As Long: HeadCount = 1
Dim Cols As Long: Cols = UBound(AR, 2)
Dim Ros As Long: Ros = (UBound(AR) - HeadCount) * Cols
Dim res() As Variant: ReDim res(1 To Ros, 1 To Cols - HeadCount)
Dim pos As Long: pos = 1

Dim myRange As Object
Dim zeroRow As Object

Dim lRow As Long
Dim m As Long
Dim cell As Range

Dim wsn As String
Dim yrn As String
Dim destpath As String

Start:
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

destpath = ' here be the data path .. and dragons

For i = 1 + HeadCount To UBound(AR) Step 1
    For j = 3 To UBound(AR, 2) - HeadCount Step 1
            res(pos, 1) = AR(i, 1)
            res(pos, 2) = AR(i, 2)
            res(pos, 3) = AR(i, 3)
            res(pos, 4) = AR(i, j + 1)
            res(pos, 5) = Val(20 & Left(AR(1, j + 1), 2)) ' YEAR
            res(pos, 6) = Val(Mid(AR(1, j + 1), 4, 2)) + IIf( _
                Weekday(WorksheetFunction.EoMonth(DateSerial(Val(20 & Left(AR(1, j + 1), 2)), Val(Mid(AR(1, j + 1), 4, 2)), Val(Mid(AR(1, j + 1), 7, 2))), 0), vbMonday) < 4 _
                And Val(Mid(AR(1, j + 1), 4, 2)) <> DatePart("m", DateSerial(Val(20 & Left(AR(1, j + 1), 2)), Val(Mid(AR(1, j + 1), 4, 2)), 6 + Val(Mid(AR(1, j + 1), 7, 2)))), _
                1, 0) ' month
'            res(pos, 6) = Val(Mid(AR(1, j + 1), 4, 2)) ' month
            res(pos, 7) = Replace(Mid(AR(1, j + 1), 12, 2), ")", "", 1, 1, vbBinaryCompare) ' week
            res(pos, 8) = Val(res(pos, 5) & Format(res(pos, 7), "00"))
            If res(pos, 4) = 0 Then
                res(pos, 9) = 0
                Else
                res(pos, 9) = 1
            End If
            pos = pos + 1
    Next j
Next i

' setting variables for file and sheet naming

yrn = "20" & Left(Sheets(1).Range("E1"), 2)

If Right(Sheets(1).Range("C2"), 3) = "Amt" Then
wsn = "A"
Else
If Sheets(1).Range("A1") = "Subs" Then
wsn = "H"
Else
wsn = "Q"
End If
End If

Workbooks.Open (destpath & "GDMI_" & yrn & ".xlsm")

' Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsn


With Sheets(wsn)
    .Cells.ClearContents
    .Range("A1:I1") = Array("KA", "MODEL.SUFFIX", "MEASURE", "VALUE", "YEAR", "MONTH", "WEEK", "INTERFACE-DATE", "CHECK")
    .Range("A2").Resize(UBound(res), UBound(res, 2)).Value = res

' == sorting and deleting unnecessary lines
    lRow = .Range("A" & Rows.Count).End(xlUp).Row
    Set myRange = .Range("A1:I" & lRow)
    myRange.Sort Key1:=.Range("I1"), Order1:=xlDescending, Header:=xlYes
    Set zeroRow = .Range("I:I").Find(What:="0", LookIn:=xlValues)

' deleting rows -- first sort and find the first 0 value in column, delete all below
    .Rows(zeroRow.Row & ":" & lRow).EntireRow.Delete
'    .Columns.AutoFit
End With

Workbooks("GDMI_" & yrn & ".xlsm").Close savechanges:=True
ActiveWorkbook.Close savechanges:=False

Set myRange = Nothing
Set zeroRow = Nothing

Finish:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Sub