txt文件转excel

Public res_cnt
Public ar_res(1 To 100, 1 To 20)
Public k
Sub main()
Call varInit
Call ReadFile
Call outputLastManyRow '输出遗漏的尾巴行数
End Sub
Private Sub ReadFile()
Application.ScreenUpdating = False
Dim iNum As Integer
iNum = FreeFile
Open ThisWorkbook.Path & "\2.ACY" For Input As #iNum
Do While EOF(iNum) = False
Line Input #iNum, strTemp
k = k + 1
Call splitByDouHao(strTemp, k)
Loop
Close #iNum
Application.ScreenUpdating = True
End Sub

Private Sub outputLastManyRow()
With Sheets("Sheet1")
If Not IsEmpty(ar_res) Then
.Cells(1, 1).Resize(UBound(ar_res), UBound(ar_res, 2)) = ar_res
End If
Call split2Workbook("结果" & res_cnt + 1)
.Cells.ClearContents
End With
End Sub
Private Sub varInit()
res_cnt = 0
k = 0
Erase ar_res
End Sub
'f = "G:\0.programming_order\bc1028\ZFI30_2500\ZFI30_2500.TXT"
Private Sub splitByDouHao(s, r)
tem = Split(s, ",")
Call saveAsArr(tem, r)
' With Sheets("Sheet1")
' .Cells(r, 1).Resize(1, UBound(tem) + 1) = Application.Transpose(Application.Transpose(tem))
' End With
If r Mod 70 = 0 Then
res_cnt = res_cnt + 1
With Sheets("Sheet1")
If Not IsEmpty(ar_res) Then
.Cells(1, 1).Resize(UBound(ar_res), UBound(ar_res, 2)) = ar_res
End If
End With
Call split2Workbook("结果" & res_cnt)
Sheets("Sheet1").Cells.ClearContents
r = 0
Erase ar_res
End If
End Sub

Private Sub saveAsArr(ar_temp, r)
For x = 0 To UBound(ar_temp)
ar_res(r, x + 1) = ar_temp(x)
Next
End Sub
Private Sub split2Workbook(resSheetName)
Application.DisplayAlerts = False
Dim Mbook As Workbook, i&
Set Mbook = ActiveWorkbook
For i = 1 To Mbook.Worksheets.Count
Mbook.Worksheets(i).Copy
' ActiveWorkbook.SaveAs Filename:="G:\0.programming_order\bc1028\ZFI30_2500\" & resSheetName & ".xlsx"
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & resSheetName & ".xlsx"
ActiveWindow.Close
Next i
Application.DisplayAlerts = True
End Sub

 

Public res_cnt
Sub ReadFile()
Dim iNum As Integer
iNum = FreeFile
Open ThisWorkbook.Path & "\ZFI30_2500.TXT" For Input As #iNum
Do While EOF(iNum) = False
Line Input #iNum, strTemp
k = k + 1
Call splitByDouHao(strTemp, k)
Loop
Close #iNum
End Sub
'f = "G:\0.programming_order\bc1028\ZFI30_2500\ZFI30_2500.TXT"
Sub splitByDouHao(s, r)

tem = Split(s, ",")
With Sheets("Sheet1")
.Cells(r, 1).Resize(1, UBound(tem) + 1) = Application.Transpose(Application.Transpose(tem))
End With

If r Mod 50000 = 0 Then
res_cnt = res_cnt + 1
拆分为工作簿 ("结果" & res_cnt)
Sheets("Sheet1").Cells.ClearContents
r = 0
End If
End Sub
Sub 拆分为工作簿(resSheetName) '制作销售报表用
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Mbook As Workbook, i&
Set Mbook = ActiveWorkbook
For i = 1 To Mbook.Worksheets.Count
Mbook.Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:="G:\0.programming_order\bc1028\ZFI30_2500\" & resSheetName & ".xlsx"
ActiveWindow.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 


Sub Test()
Dim fso As Object, fp As Object, f, m%, n%, s$, ar, br, cr, arr, i%, j%
'Range("a1").CurrentRegion = ""
f = "G:\0.programming_order\bc1028\ZFI30_2500\ZFI30_2500.TXT"
Set fso = CreateObject("scripting.filesystemobject")
Set fp = fso.getfolder(ThisWorkbook.Path)
n = 0: m = m + 1
s = fso.OpenTextfile(f).readall
ar = Split(s, vbCrLf)
br = Split(ar(0), "实时")
SecondSplit (br)
'Range("a1").Resize(UBound(br) + 1) = Application.Transpose(br)
Set fso = Nothing
End Sub

'G:\a.编程接单\bc1010\sabrina扣子\东吴人寿（2019）.txt
Sub SecondSplit(br)
Dim arRes(1 To 10000, 1 To 50)
For x = 0 To UBound(br)
k = k + 1
s1 = Split(br(x), "|!")
Sheet1.Cells(k, 1).Resize(, UBound(s1) + 1) = s1
Next
End Sub

Sub ADOForTxtWithDelimited()
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim SQL As String
Dim i As Integer
On Error GoTo ErrMsg
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=Yes;FMT=Delimited';Data Source=" & ThisWorkbook.Path
SQL = "SELECT * FROM ZFI30_2500.TXT"
Columns("A:D").ClearContents
rst.Open SQL, cnn, adOpenKeyset, adLockOptimistic

' arr = cnn.Execute(SQL).GetRows
' ReDim arrT(0 To UBound(arr, 2), 0 To UBound(arr, 1))
' For i = 0 To UBound(arr, 2)
' For j = 0 To UBound(arr, 1)
' arrT(i, j) = arr(j, i)
' Next
' Next

For i = 0 To rst.Fields.Count - 1
Cells(1, i + 1) = rst.Fields(i).Name
Next
Range("A2").CopyFromRecordset rst
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
ErrMsg:
MsgBox Err.Description, , "错误报告"
End Sub