求助导出/导入TXT~~~

mozhongtao

各位高手好！

去年曾在本版求助过一个类似的帖子

https://club.excelhome.net/thread-1650271-1-1.html

现在单元格位置有变化  无奈我一个门外汉  改来改去也不适用新情况   现再来求助

如附件    新建2409.rar (23.19 KB, 下载次数: 9)

2024-9-14 00:52 上传

点击文件名下载附件

需要把特定的单元格  导出/导入以工作簿文件名命名的TXT文件

  要求: A01.xlsm中  A1:K112  
           A02.xlsm中  A1:DH11

开头的空单元格必须要能导出/导入   导出文件的分隔符不一定要制表符   逗号或空格都可以

先谢谢大家了！

3190496160

直接打开excel文件，然后另存为制表符分割的文本文件就行了吧，没必要vba

mozhongtao

3190496160 发表于 2024-9-14 08:56
直接打开excel文件，然后另存为制表符分割的文本文件就行了吧，没必要vba

我这是批量的  附件只是举例

3190496160

mozhongtao 发表于 2024-9-14 10:37
我这是批量的  附件只是举例

呵呵呵呵呵呵呵呵

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, strFileName$, strPath$, strSaveName$, strTxt$
   
    Application.ScreenUpdating = False
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsm")
   
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                strTxt = ""
                strSaveName = strPath & Left(strFileName, InStrRev(strFileName, ".") - 1) & ".txt"
                With .Worksheets(1)
                    ar = Range(.[A1], .UsedRange)
                End With
               
                For i = 1 To UBound(ar)
                    br = Application.Index(ar, i)
                    strTxt = strTxt & vbCrLf & Join(br, vbTab)
                Next i
               
                Open strSaveName For Output As #1
                Print #1, Mid(strTxt, 3)
                Close #1
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

mozhongtao

gwjkkkkk 发表于 2024-9-15 15:31
请参考附件。。。

真是太赞啦！！！   

导出的问题解决了

可是我没把问题说清楚     还得把（经过我自己处理后）TXT导入到XLSM相同的位置（从A1开始包含空格）

还有一个小问题  就是不要固定导出/导入Sheet1  要导出/导入当前激活的Sheet  实现不了的话  就让我自定义某个Sheet

gwjkkkkk

mozhongtao 发表于 2024-9-15 17:29
真是太赞啦！！！   

导出的问题解决了

发几个处理过的TXT上来，看下行不行？

mozhongtao

gwjkkkkk 发表于 2024-9-16 06:27
发几个处理过的TXT上来，看下行不行？

不好意思  来晚了

新建01.rar (13.08 KB, 下载次数: 3)

2024-9-16 08:42 上传

点击文件名下载附件

gwjkkkkk

mozhongtao 发表于 2024-9-16 08:42
不好意思  来晚了

Option Explicit
Sub test1()
    Dim strFileName$, strPath$, strSaveName$
    Dim strResult$(), ar, br, y&, x&, n As Byte, strTxt$
   
    DoApp False
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
   
    Do Until strFileName = ""
        strSaveName = strPath & Left(strFileName, InStrRev(strFileName, ".") - 1) & ".xlsm"

        strTxt = ReadFromTextFile(ThisWorkbook.Path & "\" & strFileName)
        ar = Split(strTxt, vbLf)
        ReDim strResult(UBound(ar), UBound(Split(ar(0), vbTab)))
        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
        
        With Workbooks.Open(strSaveName)
            .ActiveSheet.Cells.Clear
            .ActiveSheet.[A1].Resize(UBound(strResult) + 1, UBound(strResult, 2)) = strResult
            .Close True
        End With

        strFileName = Dir
    Loop
   
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

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