同路径下txt导入到excel求助

酯白花

3190496160 发表于 2025-3-30 13:33
我这里出来的结果是对的呀，再说了，你目前的代码就是用wps打开txt文件，然后把这个以excel打开的txt文件 ...

不知道怎么回事，每次都是科学记数法的

gwjkkkkk

Option Explicit
Sub TEST()
    Dim Items As FileDialogSelectedItems, strPath$
    Dim strResult$(), ar, br, y&, x&, n As Byte, strTxt$
   
    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
    strTxt = ReadFromTextFile(Items(1))
    ar = Split(strTxt, vbLf)
    ReDim strResult(UBound(ar), 10 ^ 4)
    For y = 0 To UBound(ar)
        br = Split(ar(y), vbTab)
        For x = 0 To UBound(br)
            strResult(y, x) = br(x)
        Next x
    Next y
   
    Cells.Clear
    With [A1].CurrentRegion.Resize(UBound(strResult) + 1, UBound(strResult, 2) + 1)
        .Value = strResult
    End With
    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
Function ReadFromTextFile$(ByVal strFullName$, Optional ByVal strCharSet$ = "UTF-8")
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Charset = strCharSet
        .Open
        .LoadFromFile strFullName
        ReadFromTextFile = .ReadText
        .Close
    End With
End Function

gwjkkkkk

代码审核中请参考图片

quqiyuan

参考vbe2021读取txt的代码修改，仅供参考。。
15位输出会改成指数显示，所以超过15位改成文本即可

quqiyuan

代码如下。。。
Sub test()
    Dim Myr$, i%, j%, m%, n%
    Dim arr, brr, Crr
    Dim d As Object
    Dim myname$, str$
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Myr = wb.Path & "\"
    Call del
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    '    myname = ThisWorkbook.Path & "\liushui.txt"
    myname = Dir(Myr & "*.txt")
    Do While myname <> ""
        Debug.Print myname
        str = ReadTxtByADODB(Myr & myname, 3)
        arr = Split(str, vbLf)
        m = 0
        ReDim Crr(UBound(arr), 100)
        For i = 0 To UBound(arr)
            brr = Split(arr(i), vbTab)
            For j = 0 To UBound(brr)
                If Len(brr(j)) > 14 And IsNumeric(brr(j)) Then Crr(i, j) = "'" & brr(j) Else Crr(i, j) = brr(j)
            Next
            m = IIf(m > j, m, j)
        Next
        wb.Worksheets.Add after:=wb.Sheets(wb.Sheets.Count)
        ActiveSheet.[a1].CurrentRegion.Resize(UBound(Crr) + 1, m) = Crr
        ActiveSheet.Name = Split(myname, ".txt")(0)
        myname = Dir
    Loop
    Beep
    Application.ScreenUpdating = True
End Sub
   
   
Function ReadTxtByADODB(sPath, i)
    '//自定义函数的作用：指定读取txt的编码形式为UTF-8，读取txt里面所有内容
    Dim txt As String
    Dim ADO As Object, myCharset As String
    '    If Dir(sPath) = "" Then Exit Function                      '如果路径是空的，直接推出
    '    i = 1                                                      '指定txt编码类型是utf-8                                                ' GetEncoding(sPath)
    If i = 3 Then
        myCharset = "utf-8"
    ElseIf i = 2 Then                                          'ElseIf i = 2 Or i = 1 Then
        myCharset = "unicode"
    ElseIf i = 1 Then
        myCharset = "iso-8859-1"
    Else
        myCharset = "GB2312"
    End If
    Set ADO = CreateObject("adodb.stream")                     '创建ado对象，后面用这个对象的方法，读取txt内容
    With ADO
        .Charset = myCharset                                   '编码形式
        .Type = 2                                              '以正常文本形式返回
        .Open                                                  '打开ado对象
        .LoadFromFile sPath                                    '加载txt文件
        txt = .ReadText                                        '用readtxt方法读取txt所有内容
        .Close                                                 '关闭
    End With
    ReadTxtByADODB = txt                                       '返回值
End Function
   
   
   
Sub del()
    Application.DisplayAlerts = False
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then sht.Delete
    Next
    Application.DisplayAlerts = True
End Sub
   

酯白花

gwjkkkkk 发表于 2025-3-30 19:33
Option Explicit
Sub TEST()
    Dim Items As FileDialogSelectedItems, strPath$

感谢老师，完美解决了我的问题。

酯白花

quqiyuan 发表于 2025-3-30 22:55
代码如下。。。
Sub test()
    Dim Myr$, i%, j%, m%, n%

谢谢老师，万分感谢你的指点，解决了我繁重的工作力