求大神有模拟结果，本人是2007版本，万分感谢！！！

weifengcz

sheet1-sheet10全部保存文件 sheet1-sheet10全部保存文件.rar (165.26 KB, 下载次数: 9)

2024-5-10 15:38 上传

点击文件名下载附件

Qs18

试试一下。。。

weifengcz

Qs18 发表于 2024-5-10 16:23
试试一下。。。

  无法！！！怎么回事？？？

Qs18

我这边可以的。。。在试试

Qs18

我这边可以的。。。

weifengcz

Qs18 发表于 2024-5-10 16:56
我这边可以的。。。

看到了，记事本有问题，分类一下

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br$(), i&, j&, k&, n&, strJoin$
   
    Application.ScreenUpdating = False
    ReDim br(1 To Worksheets.Count)
   
    For i = 1 To Worksheets.Count
        With Worksheets(i)
            ar = Range(.[A1], .Cells(Rows.Count, "A").End(xlUp)).Value
            For k = 1 To UBound(ar)
                 n = Len(ar(k, 1))
                 If n Then
                     If n = 17 Then
                         If k = UBound(ar) Then
                             ar(k, 1) = " " & Replace(ar(k, 1), "/", "*") & "*"
                         Else
                             ar(k, 1) = " " & Replace(ar(k, 1), "/", "*")
                         End If
                     Else
                         If k = UBound(ar) Then
                             ar(k, 1) = "-" & ar(k, 1) & "-"
                         Else
                             ar(k, 1) = "-" & ar(k, 1)
                         End If
                     End If
                 End If
            Next k
            For k = 1 To UBound(ar)
                br(i) = br(i) & ar(k, 1)
            Next k
            br(i) = Mid(br(i), 2)
            
        End With
        If i <> 1 Then br(i) = vbCrLf & vbCrLf & br(i)
    Next i
   
    strJoin = Join(br, "")
    Open ThisWorkbook.Path & "\test.txt" For Output As #1
    Print #1, strJoin
    Close #1
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

weifengcz

gwjkkkkk 发表于 2024-5-10 19:47
请参考。。。

很厉害，我想要新建文件名保存。怎么写VBA代码？万分感谢老师！

gwjkkkkk

text.txt 改成你的文件名即可。。。