[英]Import fixed text file into excel using VBA
我正在使用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
而不是使用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
将此代码添加到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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.