【学习并记录012】表格内容导入txt文本文件 （[列间以~~隔开）Print #m

lgcmeli

Sub Writout()
    Dim r, i, j As Integer
    Dim s, sh As String, t As Single
    t = Timer
    Dim Msg$, bt$, Default$, MyValue, aa
    Msg = "输入一个2000到2039之间的数值："
    bt = "年份输入框"
    Default = "2010"    ' 设置缺省值。
100:
    MyValue = InputBox(Msg, bt, Default)
    If MyValue < 2000 Or MyValue > 2039 Then
        aa = MsgBox("输入年份超出范围，请重新输入或者退出。", 1)
        If aa <> vbOK Then Exit Sub
        GoTo 100
    Else
        MsgBox "你要处理的是 " & MyValue & "年的数据！"
    End If
    r = [B65536].End(xlUp).Row
    For i = 2 To r
        sh = ActiveSheet.Name
        s = s & "1~~" & Cells(i, 2).Value & "~~010000~~1~~" & Format(DateSerial(MyValue, sh, 1), "yyyymmdd") & "~~" & Format(DateSerial(MyValue, sh, Day(DateSerial(MyValue, sh + 1, 1) - 1)), "yyyymmdd") & "~~" & Day(DateSerial(MyValue, sh + 1, 1) - 1) & "~~" & Cells(i, 3).Value & "~~" & "2000~~~~" & vbCrLf
    Next
    Open ThisWorkbook.Path & "\" & sh & ".txt" For Output As #1
    Print #1, s
    Reset
   
    MsgBox Timer - t
End Sub




说明：
1，表格里每个表名必须是1，2，3，4，5，6，7，8，9，10，11，12间的任意一数字，代表月份。

2，程序运行时候会首先弹出inputbox窗口，提示用户输入年份，默认是2010。

3，确认后程序开始提取表格里的值到txt文本文件里，列之间以~~隔开。

[ 本帖最后由 lgcmeli 于 2010-3-3 17:16 编辑 ]

lgcmeli

我现在有2个困难，就是：
1，如何提高代码运行速度，也就是说如何优化上述代码？

2，如果只执行一次程序，就对工作簿里的所有表格分别依次提取内容到不同的txt文件，一般想到用FOR EACH IN循环，但是我使用后，发现速度很慢，以至于excel崩溃。不知道高手有没有办法解决？

总而言之：就是这段代码，如何优化满足对所有sheet进行一次批量处理到不同的文本文件里？

飞云楼主

关注一下，做个记号。

cflood

你的s太大了，每行存储1次就快了
    sh = ActiveSheet.Name
    Open ThisWorkbook.Path & "\" & sh & ".txt" For Output As #1
    For i = 2 To r
        s = "1~~" & Cells(i, 2).Value & "~~010000~~1~~" & Format(DateSerial(MyValue, sh, 1), "yyyymmdd") & "~~" & Format(DateSerial(MyValue, sh, Day(DateSerial(MyValue, sh + 1, 1) - 1)), "yyyymmdd") & "~~" & Day(DateSerial(MyValue, sh + 1, 1) - 1) & "~~" & Cells(i, 3).Value & "~~" & "2000~~~~" & vbCrLf
    Print #1, s
    Next
同时每行的format dateserial都不变，可以先存储到变量里，减少运算次数
如果sheet表中数据很多可以使用数组

[ 本帖最后由 cflood 于 2010-1-9 08:05 编辑 ]

lgcmeli

cflood：如何使用数组定义呢？

另，你的代码改写后生成的txt是隔行为空白行，这不是我要的结果。

[ 本帖最后由 lgcmeli 于 2010-1-9 09:22 编辑 ]

lgcmeli

版主出来说话啊？呵呵

cflood

那时因为你的变量s最后增加了vbCrLf，去掉它就没有空行了

lgcmeli

原帖由 lgcmeli 于 2010-1-8 17:55 发表
我现在有2个困难，就是：
1，如何提高代码运行速度，也就是说如何优化上述代码？

2，如果只执行一次程序，就对工作簿里的所有表格分别依次提取内容到不同的txt文件，一般想到用FOR EACH IN循环，但是我使用后，发 ...

经过多方查找研究，

终于实现了上述2个难点，也许代码还不优化，但是所需功能都已经基本实现，庆祝下。当然这里也要谢谢cflood。

新的代码如下：



Sub Allwritout()
'所有个表处理
    Dim r, i, j, m As Integer
    Dim s, sh As String, t As Single
    t = Timer
    Dim Msg$, bt$, Default$, MyValue, aa
    Msg = "输入一个2000到2039之间的数值："
    bt = "年份输入框"
    Default = "2010"    ' 设置缺省值。
100:
    MyValue = InputBox(Msg, bt, Default)
    If MyValue < 2000 Or MyValue > 2039 Then
        aa = MsgBox("输入年份超出范围，请重新输入或者退出。", 1)
        If aa <> vbOK Then Exit Sub
        GoTo 100
    Else
        MsgBox "你要处理的是 " & MyValue & "年的数据！"
    End If

    For m = 1 To Worksheets.Count
        Sheets(m).Select
        r = [B65536].End(xlUp).Row
        sh = ActiveSheet.Name
        Open ThisWorkbook.Path & "\" & sh & ".txt" For Output As #m
        For i = 2 To r
            s = "1~~" & Cells(i, 2).Value & "~~010000~~1~~" & Format(DateSerial(MyValue, sh, 1), "yyyymmdd") & "~~" & Format(DateSerial(MyValue, sh, Day(DateSerial(MyValue, sh + 1, 1) - 1)), "yyyymmdd") & "~~" & Day(DateSerial(MyValue, sh + 1, 1) - 1) & "~~" & Cells(i, 3).Value & "~~" & "2000~~~~"
            Print #m, s
        Next

        Reset

    Next
    MsgBox Timer - t
End Sub