Импорт файлов фиксированного текста в excel с использованием VBA

Question

Я работаю с импортом файла с фиксированным текстом в файл Excel с помощью VBA. У меня возникла проблема с установкой колонок (автоматическая подгонка) также с десятичной цифрой.

У меня есть -десятичные столько, сколько этот 5027.1202024.0000.0000.000.0000.0000.0000 и хотел бы упрощен только 5027,12, поскольку мои колонны не фитинг и просто отделяя. есть ли другой способ, помимо объявления нескольких массивов и фиксации его ширины? текстовый файл как-то исправлен. Я все еще новичок в vba, я бы похвалил каждую помощь. Благодаря

EDIT:

Option Explicit 
Sub ImportPrepayment() 
    Dim fpath 
    Dim x As Integer 
    Dim wkbAll As Workbook 
    Dim wkbTemp As Workbook 
    Dim sDelimiter As String 

    'Call import_TExtFileR12 

    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 

    sDelimiter = "|" 

    fpath = Application.GetOpenFilename _ 
     (FileFilter:="Text Files (*.txt), *.txt", _ 
     MultiSelect:=True, Title:="Text Files to Open") 

    If TypeName(fpath) = "Boolean" Then 
     MsgBox "No Files were selected" 
     GoTo ExitHandler 
    End If 

    x = 1 
    Set wkbTemp = Workbooks.Open(FileName:=fpath(x)) 
    wkbTemp.Sheets(1).Copy 
    Set wkbAll = ActiveWorkbook 
    wkbTemp.Close (False) 
    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _ 
     Destination:=Range("A1"), DataType:=xlDelimited, _ 
     TextQualifier:=xlDoubleQuote, _ 
     ConsecutiveDelimiter:=False, _ 
     Tab:=False, Semicolon:=False, _ 
     Comma:=False, Space:=False, _ 
     Other:=True, OtherChar:="|" 
    x = x + 1 

    While x <= UBound(fpath) 
     Set wkbTemp = Workbooks.Open(FileName:=fpath(x)) 
     With wkbAll 
      wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count) 
      .Worksheets(x).Columns("A:A").TextToColumns _ 
       Destination:=Range("A1"), DataType:=xlDelimited, _ 
       TextQualifier:=xlDoubleQuote, _ 
       ConsecutiveDelimiter:=False, _ 
       Tab:=False, Semicolon:=False, _ 
       Comma:=False, Space:=False, _ 
       Other:=True, OtherChar:=sDelimiter 
     End With 
     x = x + 1 
    Wend 


Range("A17:XFD" & x).Delete shift:=xlUp 
'Range("A1").Value = "Supplier Name" 
    ' Range("C1").Value = "Supplier Number" 
    'Range("D1").Value = "Inv Curr Code" 
    'Range("E1").Value = "Payment Cur Code" 
    'Range("F1").Value = "Invoice Type" 
    'Range("G1").Value = "Invoice Number" 
    'Range("H1").Value = "Voucher Number" 
    'Range("I1").Value = "Invoice Date" 
    'Range("J1").Value = "GL Date" 
    'Range("K1").Value = "Invoice Amount" 
    'Range("L1").Value = "Witheld Amount" 
    'Range("M1").Value = "Amount Remaining" 
    'Range("N1").Value = "Description" 
    'Range("O1").Value = "Account Number" 
    'Range("P1").Value = "Invoice Amt" 
    'Range("Q1").Value = "Withheld Amt" 
    'Range("R1").Value = "Amt Remaining" 
    'Range("S1").Value = "User Name" 


Call ProcessUsedRange 
Columns.EntireColumn.HorizontalAlignment = xlCenter 
Columns.EntireColumn.AutoFit 
ExitHandler: 
    Application.ScreenUpdating = True 
    Set wkbAll = Nothing 
    Set wkbTemp = Nothing 
    Exit Sub 

ErrHandler: 
    If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description 
    Resume ExitHandler 
End Sub 
Sub ProcessUsedRange() 
    Dim r As Range 
    Dim regex As Object, Match As Object 
    Set regex = CreateObject("VBScript.RegExp") 
    With regex 
     .Pattern = "\d{4}.\d{4}.\d{4}.\d{3}.\d{4}.\d{4}.\d{4}" 
     .Global = True 
    End With 

    For Each r In ActiveSheet.UsedRange 
     If regex.Test(r.Text) Then 
      For Each Match In regex.Execute(r.Value) 
       r.Value = "'" & Replace(r.Value, Match.Value, "") 
      Next 
     End If 
    Next 
End Sub 

Answer 1

Вместо использования TextToColumns или Workbooks.OpenText; просто прочитайте текстовый файл и обработайте данные.

Sub ImportPrepayment2() 
    Dim fpath As Variant 
    Dim wb As Excel.Workbook 
    Dim ws As Excel.Worksheet 
    Dim Text As String 
    On Error GoTo terminatemsg 

    Set wb = Excel.ActiveWorkbook 
    Set ws = Excel.ActiveSheet 

    fpath = Application.GetOpenFilename(Filefilter:="text Files(*.txt; *.txt), *.txt; *.txt", Title:="open") 

    If fpath = False Then Exit Sub 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Text = getTextfileData(fpath) 
    If Len(Text) Then 
     ProcessData Text 
     AdjustDates 
    Else 
     MsgBox fpath & " is empty", vbInformation, "Import Cancelled" 
     Exit Sub 
    End If 

    Columns.EntireColumn.AutoFit 
    Sheets(1).Move Before:=wb.Sheets(1) 

terminatemsg: 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description 

End Sub 

Sub ProcessData(Text As String) 
    Dim x As Long, y As Long, z As Long 
    Dim data, vLine 

    data = Split(Text, vbCrLf) 
    x = 2 
    Range("A1:R1").Value = Array("Supplier Name", "Supplier Number", "Inv Curr Code CurCode", "Payment CurCode", "Invoice Type", "Invoice Number", "Voucher Number", "Invoice Date", "GL Date", "Invoice Amount", "Withheld Amount", "Amount Remaining", "Description", "Account Number", "Invoice", "Withheld", "Amt", "User") 

    For y = 0 To UBound(data) 
     If InStr(data(y), "|") Then 
      vLine = Split(data(y), "|") 
      If Not Trim(vLine(0)) = "Supplier" Then 

       For z = 0 To UBound(vLine) 
        vLine(z) = Trim(vLine(z)) 

        If vLine(z) Like "*.*.*.*.*.*.*.*" Then vLine(z) = Left(vLine(z), InStr(vLine(z), ".") + 2) 

       Next 
       Cells(x, 1).Resize(1, UBound(vLine) + 1).Value = vLine 
       x = x + 1 
      End If 
     End If 
    Next 

End Sub 

Sub AdjustDates() 
    Dim x As Long 

    For x = 2 To Range("B" & Rows.Count).End(xlUp).row 
     If Cells(x, "R") = vbNullString Then Cells(x, "M").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 
    Next 

End Sub 

Function getTextfileData(FILENAME As Variant) As String 
    Const ForReading = 1 
    Dim fso, MyFile 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set MyFile = fso.OpenTextFile(FILENAME, ForReading) 
    getTextfileData = MyFile.ReadAll 
    MyFile.Close 
End Function 

Answer 2

Добавьте этот код перед Columns.EntireColumn.AutoFit.

Sub ProcessUsedRange() 
    Dim r As Range 
    Dim regex As Object, Match As Object 
    Set regex = CreateObject("VBScript.RegExp") 
    With regex 
     .Pattern = "\d{4}.\d{4}.\d{4}.\d{3}.\d{4}.\d{4}.\d{4}" 
     .Global = True 
    End With 

    For Each r In ActiveSheet.UsedRange 
     If regex.Test(r.Text) Then 
      For Each Match In regex.Execute(r.Value) 
       'The apostrophe is to keep the data formatted as text 
       r.Value = "'" & Replace(r.Value, Match.Value, "") 
      Next 
     End If 
    Next 
End Sub 

Вы должны также изменить

MsgBox Err.Number & " " & Err.Description 

в

If Err.Number <> 0 then MsgBox Err.Number & " " & Err.Description