具有可变列宽的 Excel VBA 导入 TXT 文件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/11833114/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA Import TXT File with variable Column width
提问by Dennis
I have a challenge with importing fixed with files (TXT) into Excel via VBA. The Issue is not really getting the Data into Excel (Code below) but change the column width depending on the column content of the TXT file.
我在通过 VBA 将固定文件 (TXT) 导入 Excel 时遇到了挑战。问题并不是真正将数据导入 Excel（下面的代码），而是根据 TXT 文件的列内容更改列宽。
Any Help is much appriciated !!
任何帮助都非常有用！！
Example:
例子：
The Content of the txt File is:
txt文件的内容是：
FirstC SecondC ThirdC
A 111122223333 444455556666
B 111122223333 444455556666
A 111122223333 444455556666
A 111122223333 444455556666
B 111122223333 444455556666
Depending on the content of the first Column (FirstC ) the import column width in Excel should change, i.e. for A the Column width of the Second Column (SecondC) should be 8 digits and in Case of an B it should be 10 Digits
根据第一列 (FirstC) 的内容，Excel 中的导入列宽应更改，即对于 A，第二列 (SecondC) 的列宽应为 8 位，在 B 的情况下应为 10 位
The import Code (not a pro, so sorry if the code is a bit messy):
导入代码（不是专业人士，如果代码有点乱，请见谅）：
Sub Button1_Click()
Dim vPath As Variant
vPath = Application.GetOpenFilename("TextFiles (*.txt), *.txt", , "TEST TEXT IMPORTER:")
If vPath = False Then Exit Sub
Filename = vPath
Debug.Print vPath
Worksheets("IMPORT").UsedRange.ClearContents
With Sheets("IMPORT").QueryTables.Add(Connection:="TEXT;" & CStr(vPath), Destination:=Sheets("IMPORT").Range("A2"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2)
.TextFileFixedColumnWidths = Array(14, 18, 12)
.TextFileFixedColumnWidths = Array(14, 18, 12) '<-- That's where I need to be flexible
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
below my code a bit modded and it works except that the fourth Column is not displayed. Actually more columns will be added so would be great to see where i have to tweak the code in order to be flexible with Columns. Any Idea? Thanks in advance
在我的代码下面稍微修改了一下，它可以工作，只是不显示第四列。实际上将添加更多列，因此很高兴看到我必须调整代码的位置以便灵活地使用列。任何的想法？提前致谢
Textfile (only 2 Lines, will be more in the future) looks like this:
文本文件（只有 2 行，以后会更多）看起来像这样：
0000000002666980001F2002
0000000002666980002G1020709500430120101L05200000000000000000000
Coding:
编码：
Sub Button1_Click()
Const fPath As String = "H:\MyDocs\xxxxx\TestFiles6.txt"
Const fsoForReading = 1
Const F1_LEN As Integer = 15 'Reference Number
Const F2_LEN As Integer = 4 'Cosectuive Number
Const F3_LEN As Integer = 1 'Record Type
Const F4_Len As Integer = 4 'Company Number
Dim objFSO As Object
Dim objTextStream As Object
Dim start As Integer
Dim fLen As Integer
Dim rw As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 2
Do Until objTextStream.AtEndOfStream
txt = objTextStream.Readline
f1 = Trim(Left(txt, F1_LEN))
'------------------------------------------------------------------------------------------------------------
start = F1_LEN + 1
f2 = Trim(Mid(txt, start, F2_LEN))
'------------------------------------------------------------------------------------------------------------
start = F1_LEN + F2_LEN + 1
f3 = Trim(Mid(txt, start, F3_LEN))
If f3 = "F" Then
fLen = 4
ElseIf f3 = "G" Then
fLen = 50
Else
End If
Debug.Print start
'------------------------------------------------------------------------------------------------------------
start = start + 1
f4 = Trim(Mid(txt, start, fLen))
Debug.Print f4
'------------------------------------------------------------------------------------------------------------
ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 3).Value = Array(f1, f2, f3, f4)
rw = rw + 1
Loop
objTextStream.Close
End Sub
结束子
采纳答案by Tim Williams
Untested:
未经测试：
Sub Tester()
Const fPath As String = "C:\SomeFile.txt"
Const fsoForReading = 1
Const F1_LEN As Integer = 14
Const F2_LEN_A As Integer = 8
Const F2_LEN_B As Integer = 10
Const F3_LEN As Integer = 14
Dim objFSO As Object, objTextStream As Object, txt, f1, f2, f3
Dim start As Integer, fLen As Integer
Dim rw As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 2
Do Until objTextStream.AtEndOfStream
txt = objTextStream.Readline
f1 = Trim(Left(txt, F1_LEN))
start = F1_LEN + 1
If f1 = "A" Then
fLen = 8
ElseIf f1 = "B" Then
fLen = 10
Else
'what if?
End If
f2 = Trim(Mid(txt, start, fLen))
start = start + fLen + 1
f3 = Trim(Mid(txt, start, F3_LEN))
With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 3)
.NumberFormat = "@" 'format cells as text
.Value = Array(f1, f2, f3)
'alternatively.....
'.cells(1).Value = f1
'.cells(3).Value = f3
End With
rw = rw + 1
Loop
objTextStream.Close
End Sub
