Macro fails to import text files

The only reason I can think of is moving from Excel 2003 to 2007.

My macro imports text files based on certain criteria in a folder "_chr.txt", the macro runs through, show in a message box that x files were imported but nothing is there. I get a small, strange character in cell A1 (Upper left corner) and the entire row (A) is highlighted.

I cant figure out what needs to be modified, except maybe in my Function (ImportFile)?

Option Explicit
Dim Sh4LastRow    'Sheet4 LastRow
Dim Sh4Range   'Sheet4 Range
Dim Sh4Cell   'Sheet4 cell

Sub ImportFilesInFolder_DTI()    'Import "*_chr.txt files from Calypso Table files. 10.25.11 RLS
    Dim rngOutput As Range
    Dim blnRemoveHeader As Boolean
    Dim strFile As String
    Dim strFileList() As String
    Dim intFile As Integer
    Dim strPath As String
    Dim sMyPath As String
    Dim sMyFileType As String

    If Left(ActiveWorkbook.Name, 6) = "AS9102" Or _
       Left(ActiveWorkbook.Name, 3) = "MOT" Then
        Call DynamicSheetSelect

        On Error Resume Next
        'C:\Program Files (x86)\Zeiss\Calypso\home\om\workarea\results
        sMyPath = Application.InputBox("Enter Folder path. Example: C:\CMM Data\CMM Data Files", , _
                                       "C:\Program Files (x86)\Zeiss\Calypso\home\om\workarea\results")

        If sMyPath = "False" Then Exit Sub
        On Error GoTo 0
        sMyFileType = Application.InputBox("Enter File type. Example: txt = Text file, csv = Excel CSV file, xls = Excel XLS file, xlsx = Excel XLSX file, etc.", , "txt")
        If sMyFileType = "False" Then Exit Sub
        On Error GoTo 0

        If sMyPath <> "" Or _
           sMyFileType <> "" Then

            strPath = sMyPath & "\"
            strFile = Dir(strPath & "*_chr." & sMyFileType)
            MsgBox strFile    'for testing
            While strFile <> ""
                intFile = intFile + 1
                ReDim Preserve strFileList(1 To intFile)
                strFileList(intFile) = strFile
                strFile = Dir()
            Wend
            If intFile = 0 Then
                MsgBox "No files found"
                Exit Sub
            End If

            blnRemoveHeader = False

            For intFile = 1 To UBound(strFileList)
                Set rngOutput = ImportFile(strPath & strFileList(intFile), blnRemoveHeader, rngOutput)
                blnRemoveHeader = False
                'strFilename = Dir
            Next

            'Format Colum C and add Column D on sheet4
            Columns("D:D").Select
            Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Columns("C:C").Activate

            'Remove blank rows at cell with text "END" and Blank rows
            'Remove blank rows
            With Sheets("Sheet4")    'Loop thru Column A
                Sh4LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
                Set Sh4Range = .Range("A1:A" & Sh4LastRow)
            End With
            If Sh4LastRow <> "1" Then
                Sh4LastRow = Sh4LastRow + 1
            End If

            Set rngOutput = Worksheets("Sheet4").Range("A" & Sh4LastRow)

            For Each Sh4Cell In Sh4Range
                MsgBox Sh4Cell.Address
                If Sh4Cell = "" Then
                    Rows(Sh4Cell.Row).Select
                    Selection.Delete Shift:=xlUp
                End If
            Next Sh4Cell

            'Remove rows with text, "END" in Column A
            With Sheets("Sheet4")    'Loop thru Column A
                Sh4LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
                Set Sh4Range = .Range("A1:A" & Sh4LastRow)
            End With
            If Sh4LastRow <> "1" Then
                Sh4LastRow = Sh4LastRow + 1
            End If

            For Each Sh4Cell In Sh4Range
                If Sh4Cell = "END" Then
                    Rows(Sh4Cell.Row).Select
                    Selection.Delete Shift:=xlUp
                End If
            Next Sh4Cell

            MsgBox UBound(strFileList) & " Files were Imported."

        Else
            MsgBox "User canceled the macro"
        End If
    Else

    End If
    Range("A1").Activate
End Sub

Sub DynamicSheetSelect()
    Dim ws As Worksheet
    Dim SheetsFound()
    ReDim SheetsFound(0)

    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> "Sheet4" Then
        Else
            SheetsFound(UBound(SheetsFound)) = ws.Name
            'ReDim Preserve SheetsFound(UBound(SheetsFound) + 1)
            Sheets(SheetsFound).Select
        End If
    Next ws
    'ReDim Preserve SheetsFound(UBound(SheetsFound) - 1)

    If ActiveSheet.Name = "Sheet4" Then
        Sheets(SheetsFound).Select
    Else
        MsgBox "Sheet 4 required, no files processed."
    End If
End Sub

Function ImportFile(Filename As String, RemoveHeader As Boolean, Output As Range) As Range

    On Error GoTo ErrImport

    With Output.Parent.QueryTables.Add(Connection:="TEXT;" & Filename _
                                                   , Destination:=Output)
        .Name = "XXX"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
                                         1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

    Set ImportFile = Output.Parent.Cells(Output.Parent.Rows.Count, 1).End(xlUp).Offset(2)
    If RemoveHeader Then Output.EntireRow.Delete

    Exit Function

ErrImport:
    Set ImportFile = Nothing
    Exit Function
End Function

Attached is a sample text file.
Imported as "comma delimited" (The only delimiter is "Tab"), inserted into Cell A1.

Any help, hints or tips are appreciated.

Added image to show cell A1 after running macros

Heres a little different approach

Sub ReadTabTextFile()
Const sPath As String = "C:\Users\Mike\Desktop\"
Const sFile As String = "N01-S5A-1-VB0401-5A1-SC_B_70_09-10-12_21_chr.txt"
Dim FileNum As Integer
Dim TotalFile As String
Dim arrData() As Variant


        
    FileNum = FreeFile
    ' Reads the entire file into memory all at once
    Open sPath & sFile For Binary As #FileNum
    TotalFile = Space(LOF(FileNum))
    Get #FileNum, , TotalFile
    Close #FileNum
    
    Lines = Split(TotalFile, vbNewLine)

    ReDim arrData(1 To UBound(Lines), 1 To 44)
    For x = LBound(Lines) To UBound(Lines) - 2
        Fields = Split(Lines(x), vbTab)
        For y = LBound(Fields) To UBound(Fields)
             ' Now the array can be used in the mdb comparing
             arrData(x + 1, y + 1) = Fields(y)
        Next y
    Next

    Worksheets("Sheet4").Range("A1").Resize(UBound(arrData), UBound(arrData, 2)) = arrData
End Sub

Originally Posted by mike7952

Heres a little different approach

Sub ReadTabTextFile()
Const sPath As String = "C:\Users\Mike\Desktop\"
Const sFile As String = "N01-S5A-1-VB0401-5A1-SC_B_70_09-10-12_21_chr.txt"
Dim FileNum As Integer
Dim TotalFile As String
Dim arrData() As Variant


        
    FileNum = FreeFile
    ' Reads the entire file into memory all at once
    Open sPath & sFile For Binary As #FileNum
    TotalFile = Space(LOF(FileNum))
    Get #FileNum, , TotalFile
    Close #FileNum
    
    Lines = Split(TotalFile, vbNewLine)

    ReDim arrData(1 To UBound(Lines), 1 To 44)
    For x = LBound(Lines) To UBound(Lines) - 2
        Fields = Split(Lines(x), vbTab)
        For y = LBound(Fields) To UBound(Fields)
             ' Now the array can be used in the mdb comparing
             arrData(x + 1, y + 1) = Fields(y)
        Next y
    Next

    Worksheets("Sheet4").Range("A1").Resize(UBound(arrData), UBound(arrData, 2)) = arrData
End Sub

I'm bringing up this older post because I am trying to utilize the code in Office365.
It fails at:

ReDim arrData(1 To UBound(Lines), 1 To 44)

With "Run-time error '9': Subscript out of range

I want to read a text file:
3031879-001_-_Block Shaft Assy-Addendum_10-03-2023_Serial No._1_2023-10-05_9_30_59 AM_chr.txt
(Attached) and place the data on Sheet4.
(I will eventually be reading in many text files at once).

Any assistance is appreciated.

I hate you people and your simple solutions!

Thank you.