VBA, чтобы добавить 22 трубы (|) в текстовый файл с помощью макроса

Question

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

Код у меня работает нормально, но в базу данных было добавлено 22 столбца, где текстовый файл предназначен для использования, поэтому мне нужно поставить 22 канала (|) перед идентификатором компании в файле блокнота

Первая картинка из листа Excel, где сотрудники могут вводить данные

На втором рисунке показан лист Excel, в котором данные отсортированы по шаблону "Закрытие собрания", а макрос собирает данные для преобразования в текст. Этот сортировочный лист называется "Template-EFPIA-iTOV", а столбцы серого цвета - вот что показывает макрос

На рисунке ниже видно, что идентификатор компании является последним столбцом в Template-EFPIA-iTOV.

Ниже показано, как лист "Шаблон-EFPIA-iTOV" представлен в тексте.

Вот идентификаторы компании в текстовом файле

Поскольку база данных назначения теперь имеет дополнительные 22 столбца перед идентификатором компании, мне нужно, чтобы мой макрос поместил 22 канала (|) перед идентификатором компании в текстовом документе.

Лист Excel "Шаблон EFPIA Customer" также подходит для текста, но это нормально и не требует никаких изменений.

Мой код ниже. Как всегда, любая помощь очень ценится.

Рис Макро фронтэнда

КОД

'Variables for Deduplication
Dim WB_Cust As Workbook
'File Variables
Dim DTOV_Directory As String
Dim DTOV_File As String
Dim ITOV_Directory As String
Dim ITOV_file As String

Const DELIMITER As String = "|"

' Variables for writing text into file
Dim WriteObject As Object
Dim OUTFilename As String

Dim MyWkBook As Workbook
Dim MyWkSheet As Worksheet

Dim OutputFile As String ' Output flat file name
Dim SysCode As String ' Variable for text string of system code to be filled into information system code column
Dim strFilenameOut As String ' Variable for name of file being processed. It is used for SysCode and OutputFile determination.
Dim CustAddressSave As Range


'Processing of one file. This procedure is called when only one of file types are selected
Public Sub Process_template(Directory As String, File As String, FileFlag As String)
    Application.ScreenUpdating = False 'Turns off switching of windows
    If FileFlag = "D" Then 'Variables setup for DTOV
        DTOV_Directory = Directory
        DTOV_File = File
    ElseIf FileFlag = "I" Then 'Variables setup for ITOV
        ITOV_Directory = Directory
        ITOV_file = File
    Else
        MsgBox "Unhandled Exception - Unknown files sent"
        Exit Sub
    End If
    Call Process(1, FileFlag)
    Application.ScreenUpdating = True 'Turns On switching of windows
End Sub

'Processing of two file. This procedure is called when both file types are to be processed
Public Sub Process_Templates(DTOV_Dir As String, DTOV_Fil As String, ITOV_Dir As String, ITOV_Fil As String)

    Application.ScreenUpdating = False 'Turns off switching of windows
    DTOV_Directory = DTOV_Dir
    DTOV_File = DTOV_Fil
    ITOV_Directory = ITOV_Dir
    ITOV_file = ITOV_Fil
    Call Process(2, "B")
    Application.ScreenUpdating = True 'Turns on switching of windows
End Sub


' *****************************************************************************
' Management of File to write in UT8 format
' *****************************************************************************

' This function open the file indicated to be able to write inside
Private Sub OUTFILE_OPEN(filename As String)
    Set WriteObject = CreateObject("ADODB.Stream")
    WriteObject.Type = 2 'Specify stream type - we want To save text/string data.
    WriteObject.Charset = "utf-8" 'Specify charset For the source text data.
    WriteObject.Open 'Open the stream And write binary data To the object
    OUTFilename = filename
End Sub

' This function closes the file
Private Sub OUTFILE_CLOSE()
    WriteObject.SaveToFile OUTFilename, 2
    WriteObject.Close ' Close the file
End Sub

' Write a string in the outfile
Private Sub OUTFILE_WRITELINE(txt As String)
    WriteObject.WriteText txt & Chr(13) & Chr(10)
    txt = ""
End Sub

' subprocedure to read TOV data into stream and call procedure to generate file
Public Sub generate_tov(i_Sheet_To_Process As String, _
                        i_OffsetShift As Integer)

    Dim sOut As String ' text to be written into file
    'Set OutputFile = "sarin"

    Sheets(i_Sheet_To_Process).Select

    Range("C2").Select
    'Parsing of system code from filename
    strFilenameOut = ActiveWorkbook.Name 'example - initial file name: EFPIA_DTOV-BE-MTOV-201503271324.xlsx
    SysCode = Left(strFilenameOut, InStrRev(strFilenameOut, "-") - 1) 'example - after LEFT cut EFPIA_ITOV-BE-MTOV
    SysCode = Right(SysCode, Len(SysCode) - InStrRev(SysCode, "-")) 'example - after RIGHT cut MTOV

    Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)
        If ActiveCell.Offset(0, 1).Value = "" Then
            'end-of-file reached, hence exist the do loop
            Exit Do
        End If

        ActiveCell.Value = SysCode
        ActiveCell.Offset(0, i_OffsetShift).Value = Application.WorksheetFunction.VLookup(Sheets("Template - EFPIA Customer").Cells(ActiveCell.Row, 3).Value, Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, i_OffsetShift).Value
        ActiveCell.Offset(1, 0).Select
    Loop

    OutputFile = Left(strFilenameOut, InStrRev(strFilenameOut, ".") - 1) & ".txt"

    If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
        MsgBox ("incorrect data in the TOV source file. Please correct and re-run the macro")
        Exit Sub
    Else
        Call generate_file
    End If


End Sub

' procedures to write stream data into file for both TOV and customer
Public Sub generate_file()

     Dim X As Integer
     Dim Y As Long
     Dim FieldValue As String
     Dim NBCol As Integer
     Dim sOut As String ' text to be written into file


     OUTFILE_OPEN (OutputFile) 'Open (setup) the output file
     'Open OutputFile For Output As #1 'Prepares new file for output
     Set MyWkBook = ActiveWorkbook
     Set MyWkSheet = ActiveSheet
     NBCol = 0

     Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
        NBCol = NBCol + 1
     Loop
        ' Scroll all rows
     Y = 1
     Do While (Trim(MyWkSheet.Cells(Y, 4)) <> "")
        sOut = ""
        For X = 1 To NBCol
            ' here, if required, insert a convertion type function
            FieldValue = Trim(MyWkSheet.Cells(Y, X))
            FieldValue = Replace(FieldValue, "|", "/") 'Replaces pipes from input file to slashes to avoid mismatches during ETL

            If FieldValue = "0" Then FieldValue = "" 'Replaces "only zeroes" - might need redoing only for amount columns
            If InStr(MyWkSheet.Cells(1, X), "Amount") > 0 Then FieldValue = Replace(FieldValue, ",", ".")

            ' add into the string
            If X = NBCol Then
                sOut = sOut & FieldValue
            Else
                sOut = sOut & FieldValue & DELIMITER
            End If

        Next X
        Y = Y + 1
        OUTFILE_WRITELINE sOut
     Loop
    OUTFILE_CLOSE

End Sub

' read the customer data into stream
Public Sub read_customer(i_Sheet_To_Process As String, _
                         i_range As String)

    Dim CCST As Workbook ' Variable to keep reference for template Workbook that is being used for copy-paste of Customer data into virtuall Workbook

    Sheets(i_Sheet_To_Process).Select
    ActiveSheet.UsedRange.Copy
    Set CCST = ActiveWorkbook
    WB_Cust.Activate

    If i_range = "" Then
        Sheets("Sheet1").Range(CustAddressSave.Address).PasteSpecial xlPasteValues
        Range(CustAddressSave.Address).Select
        ActiveCell.Offset(0, 2).Select
        Rows(CustAddressSave.Row).EntireRow.Delete
    Else
        Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
        Range("C2").Select
    End If

    'Call LookingUp(CCST)
    Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)

        If ActiveCell.Offset(0, 1).Value = "" Then
            'end-of-file reached, hence exist the do loop
            Exit Do
        End If

        ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
        ActiveCell.Value = SysCode
        ActiveCell.Offset(1, 0).Select
    Loop

    If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
        MsgBox ("incorrect data in the source file. Please correct and re-run the macro")
        Exit Sub
    Else
        Set CustAddressSave = ActiveCell.Offset(0, -2) 'Saves position where 2nd Cust data sheet will be copied
        OutputFile = Left(Mid(strFilenameOut, 1, (InStr(strFilenameOut, "_"))) & "CUST" & Mid(strFilenameOut, (InStr(strFilenameOut, "-"))), InStrRev(strFilenameOut, ".") - 1) & ".txt"
    End If

End Sub


'Main Procedure of the module that processes the files
Private Sub Process(Loops As Integer, FileFlag As String) 'Loops - number of files (1 or 2), FileFlag - which file is to be processed (I - ITOV, D - DTOV, B - Both)

    Set WB_Cust = Workbooks.Add
    ' This virtual workbook is created only for duration of the processing. It is used to copy paste CUSTOMER data form one or both templates.

    If FileFlag = "D" Or FileFlag = "B" Then
        ' process DTOV first always
        Call Open_DTOV

        '----------------------------------------------------------
        Call generate_tov("Template - Transfer of Value", 3)
        ' if the file have data issues, then abort the procedure.
        If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
            GoTo HandleException
        End If

        '----------------------------------------------------------
        Call read_customer("Template - EFPIA Customer", "A")
        ' if the file have data issues, then abort the procedure.
        If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
            GoTo HandleException
        End If
    End If



    If FileFlag = "I" Or FileFlag = "B" Then
        Call Open_ITOV

        '----------------------------------------------------------
        Call generate_tov("Template - EFPIA iToV", 17)
        ' if the file have data issues, then abort the procedure.
        If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
            GoTo HandleException
        End If

        '----------------------------------------------------------
        If FileFlag = "B" Then
            Call read_customer("Template - EFPIA Customer", "")
        Else
            Call read_customer("Template - EFPIA Customer", "A")
        End If

        ' if the file have data issues, then abort the procedure.
        If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
            GoTo HandleException
        End If

    End If

    Call Deduplicate
    Call generate_file ' generate single customer file

    MsgBox "Export Process is completed"

HandleException:
    ' Closes the virtual workbook used for consolidation and deduplication of customers
    WB_Cust.Saved = True
    WB_Cust.Close
    ActiveWorkbook.Saved = True 'Closes Template
    ActiveWorkbook.Close (False)
    If Loops = 2 Then 'Closes second Template if two files are being processed
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close (False)
    End If
    Application.ScreenUpdating = True 'Turns back on switching to exported excel file once it gets opened

    Exit Sub
End Sub

'Unused Procedure to reduce Customer data processing code. Does not work now.
Private Sub LookingUp(CCST As Workbook)
    Do Until (ActiveCell.Offset(0, 1).Value = "")
        ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
        ActiveCell.Value = SysCode
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub

'Open DTOV Template
Private Sub Open_DTOV()
    Workbooks.Open (DTOV_Directory + DTOV_File)
End Sub

'Open ITOV Template
Private Sub Open_ITOV()
    Workbooks.Open (ITOV_Directory + ITOV_file)
End Sub

'Deduplicating Customer data based on Source_Party_Identifier, which already contains source code prefix
Private Sub Deduplicate()
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=4, Header:=xlYeas
End Sub

Answer 1

Так как ваш код настроен для определения количества столбцов, используя этот раздел generate_file:

Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
    NBCol = NBCol + 1
Loop

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

Однако, если вы хотите настроить его на жюри, чтобы выполнить работу, вы всегда можете добавить 22 канала в каждую выходную строку. замещать OUTFILE_WRITELINE sOut в generate_file цикл с OUTFILE_WRITELINE "||||||||||||||||||||||" & sOut,

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