Экспорт данных Excel в текстовый файл фиксированной ширины - расположение полей

Question

Позвольте мне начать с того, что я немного новичок в работе с файлами с разделителями. Я пытаюсь подражать, как часть программного обеспечения выкладывает текстовый файл, используя Excel.

Вот код, который я использую для создания текстового файла на листе:

Sub Export_Selection_As_Fixed_Length_File()
     ' Dimension all  variables.
    Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
    Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
    Dim sht As Worksheet

    'Below are options incase you want to change the folder where VBA stores the .txt file
    'We use ActiveWorkbook.Path in this example
    'ActiveWorkbook.Path 'the activeworkbook
    'ThisWorkbook.Path  'the workbook with the code
    'CurDir  'the current directory (when you hit File|open)


    'If a cell is blank, what character should be used instead
    Filler_Char_To_Replace_Blanks = " "

        'Check if the user has made any selection at all
        If Selection.Cells.Count < 2 Then
            MsgBox "Nothing selected to export"
            Selection.Activate
            End
        End If

    'This is the destination file name.
    DestinationFile = ActiveWorkbook.Path & "/textfile.txt"
    'Obtain next free file handle number.
    FileNum = FreeFile()

     ' Turn  error checking off.
    On Error Resume Next

     ' Attempt to open destination file for output.
    Open DestinationFile For Output As #FileNum

     ' If an error occurs report it and end.
    If Err <> 0 Then
         MsgBox "Cannot open filename " & DestinationFile
         Selection.Activate
        End
    End If

     ' Turn error checking on.
    On Error GoTo 0

     '  Loop for each row in selection.
    For RowCount = 1 To Selection.Rows.Count
                For ColumnCount = 1 To Selection.Columns.Count
                    CellValue = Selection.Cells(RowCount, ColumnCount).Text
                    If (IsNull(CellValue) Or CellValue = "") Then CellValue = Filler_Char_To_Replace_Blanks
                    FieldWidth = Cells(1, ColumnCount).Value
                    If (ColumnCount = Selection.Columns.Count) Then
                            Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "@")) & vbCrLf;
                    Else: Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "@"));
                    End If
                Next ColumnCount
         ' Start next iteration of RowCount loop.
    Next RowCount
     ' Close destination file.
    Close #FileNum
    Selection.Activate
    Workbooks.OpenText Filename:=DestinationFile
End Sub

Программное обеспечение, которое я пытаюсь эмулировать, имеет "местоположения данных" и "размеры полей". Например, одно поле имеет местоположение данных 77, что означает, что оно будет начинаться с 77-го символа в строке в текстовом файле. (Я не знаю, насколько это распространено, поэтому, если это очень часто, извините за бесполезную информацию.) И размер поля равен 12.

Если это не имеет смысла, вот скриншот текстового файла. Первая строка показывает, что создает мой VBA, а вторая - то, как я хочу, чтобы он выглядел. Как заставить значения на рабочем листе начинаться с определенной позиции в строке на основе столбца, в котором он находится?

Answer 1

Похоже, ваша первая строка в выделении содержит ширину поля FieldWidth = Cells(1, ColumnCount).Value, В описании проблемы вы указали расположение данных и размеры полей. Вы должны иметь эту информацию где-нибудь. Вы можете поместить его на другой лист в файле, что позволит вам настроить вывод текстового файла, или вы можете поместить эти значения в свой код VBA как константы, или вы можете создать класс. Используя что-то вроде этого, вы сможете переопределять поля по мере необходимости. В приведенном ниже примере используется простой класс и несколько частных функций в модуле.

В приведенном ниже примере вам нужно добавить лист с именем "FieldControl" и поместить соответствующие значения в столбцы. GetFieldControl функция. Для проверки кода я использовал следующее:

Вам нужно будет добавить следующую ссылку в вашу книгу макросов. В редакторе VBA в меню "Сервис" выберите "Ссылки", затем, когда появится диалоговое окно, выберите "Microsoft Scripting Runtime". (Инструменты-> Список литературы)

И со всем, что связано с кодом, есть улучшения, которые можно сделать в этом.

Удачи вам в ваших усилиях

Класс (Insert->Class) меняет имя по умолчанию на clField (вы можете называть его как угодно, но не забудьте обновить оператор dim GetFieldControl Функция соответствует имени, которое вы дали.)

Option Explicit

Public Enum eFieldType
    Number
    Text
End Enum

Public Name As String
Public Size As Long
Public StartPos As Long
Public Value As String
Public FieldType As eFieldType

Модуль с несколькими обновлениями

Option Explicit
Option Base 1    'This makes any defined array start a 1 rather than 0

Sub Export_Selection_As_Fixed_Length_File()
     ' Dimension all  variables.
    Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
    Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
    Dim sht As Worksheet

    Dim outputRecord() As String
    'Below are options in case you want to change the folder where VBA stores the .txt file
    'We use ActiveWorkbook.Path in this example
    'ActiveWorkbook.Path 'the activeworkbook
    'ThisWorkbook.Path  'the workbook with the code
    'CurDir  'the current directory (when you hit File|open)

    'If a cell is blank, what character should be used instead
    Filler_Char_To_Replace_Blanks = "+"

    'Check if the user has made any selection at all
    If Selection.Cells.Count < 2 Then
        MsgBox "Nothing selected to export"
        Selection.Activate
        End
    End If

    'This is the destination file name.
    DestinationFile = ActiveWorkbook.Path & "\textfile.txt"  'This was changed to the DOS version of directory separator

    On Error GoTo catchFileOpenError    'Poor man's version of Try/Catch

    'Get a FileSystemObject using the MSFT Scripting Runtime reference
    Dim fd As Scripting.FileSystemObject
    Set fd = New Scripting.FileSystemObject

    Dim outputFile As Object
    Set outputFile = fd.CreateTextFile(DestinationFile, True, False)

    ' Turn error checking on.
    On Error GoTo 0

    Dim record As Scripting.Dictionary
    'Call a private function that gets the filed control information from the
    'Sheet titled FieldControl and the associated range
    Set record = GetFieldControl(ActiveWorkbook.Sheets("FieldControl").Range("A2:D7"))

    'Declare enumerators to loop through the selection
    Dim dataRow As Range
    Dim dataFld As Range

    'Declare the output buffer, 80 characters
    Dim outputBuffer(80) As Byte
    'loop thru the selection row by row
    For Each dataRow In Selection.Rows
        'Initialize buffer to empty value defined by the second parameter
        Call InitOutputBuffer(outputBuffer, Filler_Char_To_Replace_Blanks)
        'Loop thru each field in the row
        For Each dataFld In dataRow.Columns
            'Copy the input value into the output byte array
            Call CopyStringToByteArray(outputBuffer, StrConv(Trim(CStr(dataFld.Value2)), vbFromUnicode), _
                        record(dataFld.Column).StartPos, record(dataFld.Column).FieldType, record(dataFld.Column).Size)
        Next dataFld
        'Write the record to the text file but first convert ASCII Byte to Unicode String
        'Also this method places CR/LF as part of the output to the file
        outputFile.WriteLine StrConv(outputBuffer, vbUnicode)
    Next dataRow

     ' Close destination file.
    outputFile.Close

    Selection.Activate
    Workbooks.OpenText Filename:=DestinationFile
    Exit Sub

catchFileOpenError:     'Catch the error after trying if openning the file fails
    On Error GoTo 0
    MsgBox "Cannot open filename " & DestinationFile
    Selection.Activate
End Sub
'***********************************************************************************
'*
'* PARAMETERS:
'*  outBuf is the updated buffer
'*  inBuf is the input buffer that needs to be copied to the output buffer (buffer)
'*  startCol is the starting column for the field
'*  fldTy is the field type as defined by the class enumerator eFieldType
'*  fldLen is the length of the field as defined on the control sheet
Private Sub CopyStringToByteArray(ByRef outBuf() As Byte, ByRef inBuf() As Byte, _
                ByVal startCol As Long, ByRef fldTy As eFieldType, ByVal fldLen As Long)
    Dim idx As Long
    If fldTy = Text Then       'Left Justified
        For idx = LBound(inBuf) To UBound(inBuf)
            outBuf(startCol) = inBuf(idx)
            startCol = startCol + 1
        Next idx
    Else                        'Right Justified
        Dim revIdx As Long
        revIdx = startCol + fldLen - 1
        For idx = UBound(inBuf) To LBound(inBuf) Step -1
            outBuf(revIdx) = inBuf(idx)
            revIdx = revIdx - 1
        Next idx
    End If
End Sub
'***************************************************************************
'*  InitOutputBuffer
'*      PARAMETERS:
'*          buffer is the buffer to initialize
'*          initVal is a string containing the value used to initialize the buffer
Private Sub InitOutputBuffer(ByRef buffer() As Byte, ByVal initVal As String)
    Dim byInitVal() As Byte 'Byte array to hold the values from the string conversion
    byInitVal = StrConv(initVal, vbFromUnicode) 'convert the string into an ASCII array
    Dim idx As Long
    For idx = LBound(buffer) To UBound(buffer)
        buffer(idx) = byInitVal(0)
    Next idx

    'buffer(81) = Asc(Chr(13)) 'Carriage Return Character
    'buffer(82) = Asc(Chr(10)) 'Line Feed Character

End Sub

'*******************************************************************************
'*
'*  GetFieldControl
'*      PARAMETERS:
'*          ctrlRng is the range on a worksheet where the field control info is
'*              found
'*      REMARKS:
'*          The range needs to have the following columns: Name, Size, Start Postion
'*          and Type.  Type values can be Text or Number
Private Function GetFieldControl(ByRef ctrlRng As Range) As Scripting.Dictionary
    Dim retVal As Scripting.Dictionary
    Set retVal = New Scripting.Dictionary

    'format of control range is : Name, Size, Start Position, Type
    Dim fldInfoRow As Range
    Dim fld As clField  'A class that holds the control values from the work sheet
    Dim colCnt As Long: colCnt = 1  'Becomes the key for the dictionary
    For Each fldInfoRow In ctrlRng.Rows
        Set fld = New clField
        fld.Name = fldInfoRow.Value2(1, 1)      'Name of field in data table
        fld.Size = fldInfoRow.Value2(1, 2)      'Output Size of field
        fld.StartPos = fldInfoRow.Value2(1, 3)  'Output starting position for this field
        Select Case fldInfoRow.Value2(1, 4)     'Controls how the output value is formated
            Case "Text"                         '  Text left justified, Numbers are right justified
                fld.FieldType = Text
            Case "Number"
                fld.FieldType = Number
            Case Default
                fld.FieldType = Text
        End Select
        retVal.Add Key:=colCnt, Item:=fld   'Add the key and the fld object to the dictionary
        colCnt = colCnt + 1                 'This key value is mapped to the column number in the input data table
    Next fldInfoRow

    'Return the scripting Dictionary
    Set GetFieldControl = retVal
End Function