Results 1 to 6 of 6

Macro fails to import text files

Threaded View

  1. #1
    Forum Contributor Rick_Stanich's Avatar
    Join Date
    11-21-2005
    Location
    Ladson SC
    MS-Off Ver
    Office365
    Posts
    1,177

    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.
    Regards

    Rick
    Win10, Office 365

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1