使用VBA从文本文件写入excel时保留“列”

Question

I have a text file that is formatted in the following way:

And I am using the below code in VBA to write the text file into excel:

Sub Test()

 Dim Fn As String, WS As Worksheet, st As String

 Fn = "Path.txt" ' the file path and name
 Set WS = Sheets("Sheet1")

 'Read text file to st string
 With CreateObject("Scripting.FileSystemObject")
    If Not .FileExists(Fn) Then
        MsgBox Fn & "  : is missing."
        Exit Sub
    Else
        If FileLen(Fn) = 0 Then
            MsgBox Fn & "  : is empty"
            Exit Sub
        Else
            With .OpenTextFile(Fn, 1)
             st = .ReadAll
             .Close
            End With
        End If
    End If
 End With

 'Replace every two or more space in st string with vbTab
 With CreateObject("VBScript.RegExp")
  .Pattern = "[ ]{2,}"
  .Global = True
  .Execute st
  st = .Replace(st, vbTab)
 End With

 'Put st string in Clipboard
 With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText st
    .PutInClipboard
 End With

 'Paste Clipboard to range
 WS.Range("A1").PasteSpecial

End Sub

My goal is to preserve the columns from the text file in Excel.

However, my code can't tell that a blank space under Plan Type and a blank space under Benefit Plan are actually two different columns of data. It treats the blank space under the two columns as one long blank space, and the formatting isn't preserved.

Visually we know there are columns, but my code cannot see this.

Is there a way to program this so it recognizes that there are two spaces in the text file instead of one big space?

What I want to avoid is having to manually deliminate this with a character. Is that possible?

Answer 1

Assuming that each column is 10 characters long, I would use this width instead of a space delimeter

Sub FeedTextFileToActiveSheet(ByVal TextFile As String)
  Dim i As Integer, Line As String
  Open TextFile For Input As #1
  While Not EOF(#1)
    i = i + 1
    Input #1, Line
    Range("A" & i) = Trim(Mid(Line, 1, 10))  'Business ID
    Range("B" & i) = Trim(Mid(Line, 11, 10)) 'Employee ID
    ' ... and so on
  Wend
  Close #1
End Sub

To use it, just call FeedTextFileToActiveSheet("Path.txt")

Answer 2

Have you tried the "import from text file option" of excel? If you just want to import the text file to excel with or without headers, then you can import directly in excel using the built in option available in excel .This recognises the header and blank spaces properly.One point to be noted is the headers of the text file should always be in first line for this method. If you are not sure of this, then you can go for a vba script.if so, then the link provided by ferdinando will help you.

Answer 3

If you have this file organized visually, I would go by that logic. It means that value of a column starts where the column header starts. This implies that value of a column ends where the next one begins.

Helpful image, describing the logic (also, example text file I used):

All this logic can be done by reading first line, which contains headers, and determining all indexes of beginning of every header. Then, for each line we can easily determine value between two particular indexes, cut it out and trim to remove extra spaces at the beginning and at the end of a value.

Try below code (all necessary comments in code):

Sub ReadDataFromCsv()
    Dim Fn As String, WS As Worksheet, st As String, i As Long, columnHeadersIndexes As Object, numberOfColumns As Long
    Fn = "your path here" ' the file path and name
    Set WS = Sheets("Sheet1")
    ' Create array that will hold indexes of a beginning of a column header
    Set columnHeadersIndexes = CreateObject("System.Collections.ArrayList")
    'Read text file to st string
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(Fn) Then
            MsgBox Fn & "  : is missing."
            Exit Sub
        ElseIf FileLen(Fn) = 0 Then
            MsgBox Fn & "  : is empty"
        Else
            With .OpenTextFile(Fn, 1)
                ' Read first line
                st = .ReadLine
                i = 1
                ' Find beginning of first column name
                Do While Mid(st, i, 1) = " "
                    i = i + 1
                Loop
                columnHeadersIndexes.Add (i)
                ' At least two spaces separate two headers, so we can safely add 2 without risk of loosing any letters frmo next header
                i = i + 2
                Dim j As Long: j = 1
                Do While i < Len(st)
                    ' If we have two spaces followed by non-space, then save index (beginning of a header)
                    If Mid(st, i - 2, 2) = "  " And Mid(st, i, 1) <> " " Then
                        ' Set column header
                        Cells(1, j) = Mid(st, columnHeadersIndexes(columnHeadersIndexes.Count - 1), i - columnHeadersIndexes(columnHeadersIndexes.Count - 1) - 1)
                        columnHeadersIndexes.Add (i)
                        j = j + 1
                    End If
                    i = i + 1
                Loop
                ' Set column header
                Cells(1, j) = Trim(Mid(st, columnHeadersIndexes(columnHeadersIndexes.Count - 1), Len(st)))
                numberOfColumns = columnHeadersIndexes.Count
                ' Skip line with ------ characters
                .ReadLine
                Dim currentRow As Long: currentRow = 2
                Do While .AtEndOfStream <> True
                    st = .ReadLine
                    ' Read all columns from a line
                    For i = 0 To numberOfColumns - 2
                        If Len(st) >= columnHeadersIndexes(i) Then
                            cellValue = Mid(st, columnHeadersIndexes(i), columnHeadersIndexes(i + 1) - columnHeadersIndexes(i) - 1)
                            cellValue = Trim(cellValue)
                            Cells(currentRow, i + 1) = cellValue
                        End If
                    Next
                    ' Read last column, if exists
                    If Len(st) >= columnHeadersIndexes(i) Then
                        'here we pass Len(st) as length for substring - it assures that we don't pass too small value and miss some characters
                        cellValue = Mid(st, columnHeadersIndexes(i), Len(st))
                        cellValue = Trim(cellValue)
                        Cells(currentRow, i + 1) = cellValue
                    End If
                    currentRow = currentRow + 1
                Loop
                .Close
            End With
        End If
    End With
End Sub

Answer 4

If the file looks exactly alike the image when opened in notepad, most probably it is fixed width . Whatever may be the case better go a blank workbook, start Record Macro and simply try to open the text file. Automatically Text import wizard will open. Chose type as Fixed Width (preferably) or delimited, go through each step carefully reading the guiding instruction provided. (When asked for start import at row, it is better to give first line containing significant data, omitting header lines etc). When the file is fully opened stop the recording. You will have a recorded macro something like this.

Workbooks.OpenText Filename:="C:\Users\user\Desktop\Text.prn", Origin:= _
        xlMSDOS, StartRow:=5, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1) _
        , Array(14, 1), Array(29, 1), Array(44, 1), Array(59, 1), Array(74, 5), Array(89, 1), Array( _
        104, 1)), TrailingMinusNumbers:=True

Now simply use that portion of code (may be with little modification in filename etc) in your procedure to Open the text file. Then simply copy the current region and paste in a work sheet already made ready with headers etc like.

ActiveWorkbook.ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets(1).Range("a5")
 ActiveWorkbook.Close False

Answer 5

you could:

• process the line with all "-"s, to get the actual fields width

• paste all text content into wanted sheet column A rows

• use TextToColumns() method to spread text from column A into as many columns as needed, determined by proper handling of the "-"s line

as follows:

Option Explicit

Sub Test()

    Dim Fn As String, WS As Worksheet
    Dim lines As Variant, line As Variant

    Fn = "Path.txt" ' the file path and name
    Set WS = Sheets("Sheet1")

    'Read text file to st string
    With CreateObject("Scripting.FileSystemObject")
       If Not .FileExists(Fn) Then
           MsgBox Fn & "  : is missing."
           Exit Sub
       Else
           If FileLen(Fn) = 0 Then
               MsgBox Fn & "  : is empty"
               Exit Sub
           Else
                With .OpenTextFile(Fn, 1)
                    lines = Split(.readall, vbLf)
                    .Close
                End With
           End If
       End If
    End With

    For Each line In lines ' loop through all text lines
        If InStr(line, "-") > 0 Then Exit For ' loop till you reach the "-"s line, which will be used to get FieldInfo array for textToColumns method
    Next

    With WS
        .Range("a1").Resize(UBound(lines) + 1).Value = Application.Transpose(lines) ' copy all text lines into column A rows
        .Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, FieldInfo:=GetFieldInfo(Trim(line)), TrailingMinusNumbers:=True ' convert text to columns feeding FieldInfo array arranged from the "-"s line structure
    End With

End Sub


Function GetFieldInfo(st As String) As Variant()
    Dim i As Long, n As Long, nFields As Long

    nFields = UBound(Split(WorksheetFunction.Trim(st), " ")) ' get the number of fields by counting the "-"s groups separated by single space

    ReDim arrtext(0 To nFields) ' size FieldInfo array accordingly
    Do
        arrtext(i) = Array(n, 1) ' build current FieldInfo array field with current field position in text
        n = InStr(n + 1, st, " -") ' search next field position
        i = i + 1
    Loop While i < nFields
    arrtext(i) = Array(n, 1) ' build last FieldInfo array field with last field position in text

    GetFieldInfo = arrtext ' return FieldInfo array
End Function