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

Question

我正在使用VBA將固定文本文件導入excel文件。 我在用數字十進制固定列的擬合（自動擬合）時遇到問題。

我有一個最多為5027.1202024.0000.0000.000.0000.0000.0000的小數，並且想簡化為5027.12，因為我的列不合適並且只是分開。 除了聲明幾個數組並固定寬度之外，還有別的方法嗎？ 文本文件已經以某種方式固定。 我還是vba的新手，我會盡一切幫助。 謝謝

編輯：

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