Сохранение "столбцов" при записи из текстового файла в Excel с использованием VBA

У меня есть текстовый файл, который форматируется следующим образом:

enter image description here

И я использую приведенный ниже код в VBA для написания текстового файла в 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

Моя цель - сохранить столбцы из текстового файла в Excel.

Тем не менее, мой код не может сказать, что пустое пространство в разделе " Plan Type и пустое пространство в разделе " Benefit Plan на самом деле представляют собой два разных столбца данных. Он обрабатывает пустое пространство под двумя столбцами как одно длинное пустое пространство, и форматирование не сохраняется.

Визуально мы знаем, что есть столбцы, но мой код не видит этого.

Есть ли способ запрограммировать это, чтобы он распознал, что в текстовом файле есть два пробела вместо одного большого пространства?

То, что я хочу избежать, - это вручную разграничить это с символом. Это возможно?

+6
источник поделиться
5 ответов

Предполагая, что каждый столбец имеет длину 10 символов, я бы использовал эту ширину вместо пространственного разделителя

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

Чтобы использовать его, просто вызовите FeedTextFileToActiveSheet("Path.txt")

+5
источник

Вы пробовали вариант "импорт из текстового файла" excel? Если вы просто хотите импортировать текстовый файл в excel с заголовками или без них, вы можете импортировать напрямую в excel, используя встроенную опцию, доступную в excel. Это правильно распознает заголовок и пробелы. Одной из отметок является заголовок текстовый файл всегда должен быть в первой строке для этого метода. Если вы не уверены в этом, вы можете пойти на скрипт vba. Если так, то ссылка, предоставленная ferdinando, поможет вам.

+3
источник

Если у вас этот файл организован визуально, я бы пошел по этой логике. Это означает, что значение столбца начинается с начала заголовка столбца. Это означает, что значение столбца заканчивается, когда начинается следующий.

Полезное изображение, описывающее логику (также пример текстового файла, который я использовал):

enter image description here

Вся эта логика может быть выполнена путем чтения первой строки, содержащей заголовки, и определения всех индексов начала каждого заголовка. Затем для каждой строки мы можем легко определить значение между двумя конкретными индексами, вырезать его и обрезать, чтобы удалить лишние пробелы в начале и в конце значения.

Попробуйте под кодом (все необходимые комментарии в коде):

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
+2
источник

Если файл выглядит точно как изображение, открытое в блокноте, скорее всего, это фиксированная ширина. Как бы то ни было, лучше пойдите в пустую книгу, начните запись макроса и просто попробуйте открыть текстовый файл. Автоматически откроется мастер импорта текста. Выберите тип фиксированной ширины (предпочтительно) или разделите, пройдите каждый шаг, внимательно прочитав прилагаемую инструкцию. (При запросе на запуск импорта по строке лучше указать первую строку, содержащую значительные данные, опуская строки заголовков и т.д.). Когда файл полностью открыт, остановите запись. У вас будет записан макрос что-то вроде этого.

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

Теперь просто используйте эту часть кода (возможно, с небольшими изменениями в имени файла и т.д.) В вашей процедуре, чтобы открыть текстовый файл. Затем просто скопируйте текущий регион и вставьте в рабочий лист, уже готовый с заголовками и т.д.

ActiveWorkbook.ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets(1).Range("a5")
 ActiveWorkbook.Close False
+1
источник

вы могли бы:

  • обработать линию со всеми "-" s, чтобы получить фактическую ширину полей

  • вставлять весь текстовый контент в таблицу требуемых столбцов. Строки

  • используйте TextToColumns() для распространения текста из столбца A на столько столбцов, сколько необходимо, определяемое путем правильной обработки строки "-"

следующее:

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
0
источник

Посмотрите другие вопросы по меткам или Задайте вопрос