使用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