提取TXT文档中内容到EXCEL表中

lcb520

提取文本文档中的数据到EXCEL表格中。

wxxydl

给你做了一个

liulang0808

Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文本文件"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt"
        If .Show Then F = .SelectedItems(1) Else Exit Sub '
    End With
    arr = Split(ReadUTF(F), "   ^^")
    ReDim brr(1 To UBound(arr) + 1, 1 To 2)
    For j = 0 To UBound(arr)
        If Len(arr(j)) > 0 Then
            crr = Split(arr(j), "     ")
            brr(j + 1, 1) = crr(0)
            brr(j + 1, 2) = crr(1)
        End If
    Next j
    [g2].Resize(UBound(brr), 2) = brr
End Sub
Function ReadUTF(ByVal FileName As String) As String
    With CreateObject("ADODB.Stream")
        .Type = 2    '读取文本文件
        .Mode = 3   '读写
        .Open
        .LoadFromFile FileName
        .Charset = "UTF-8"  '设定编码
        .Position = 2
        ReadUTF = .ReadText
        .Close
    End With
End Function

liulang0808

附件内容供参考。。。。

fzxba

提取编码.zip (18.99 KB, 下载次数: 12)

2024-3-20 11:17 上传

点击文件名下载附件

taller

tanglf188

参与一下

lisongmei

整着玩，上个python的

gwjkkkkk

Option Explicit
Sub TEST()
    Dim Items As FileDialogSelectedItems, strPath$
    Dim strResult$(), ar, br, y&, x&, n As Byte
   
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "文本文件(txt)", "*.txt"
        End With
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    Application.ScreenUpdating = False
    n = FreeFile
    Open Items(1) For Input As #n
        ar = Split(StrConv(InputB(LOF(n), #n), vbUnicode), "   ^^")
    Close #n
    ReDim strResult(UBound(ar), 1)
   
    For y = 0 To UBound(ar)
        br = Split(ar(y), "     ")
        For x = 0 To UBound(br)
            strResult(y, x) = br(x)
        Next x
    Next y
   
    Cells.Clear
    [A1].Resize(, 2) = Split("编号 数量")
    [A2].Resize(UBound(strResult) + 1, 2) = strResult
  
    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。