使用VBA將固定文本文件導入到excel中

Question

我正在使用VBA將固定文本文件導入到excel文件中。 我有一個問題，修正列（自動擬合）與數字的小數的擬合。

我有一個小數儘可能多5027.1202024.0000.0000.000.0000.0000.0000並想簡化爲5027.12，因爲我的列不合適，只是分離。除了聲明幾個數組並修復它的寬度之外，還有另一種方法嗎？該文本文件已被固定。 我還是新手，我會幫助你。由於

編輯：

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