[已解决]请教导出问题

yvll

请教导出问题，谢谢！
请教导出问题.rar (7.46 KB, 下载次数: 14)

2015-1-25 18:38 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

芐雨

2015-1-27 17:23

1. Sub t()
   
2.     Dim arr, i&, j&, s, m%
   
3.     Dim myPath, fs, f
   
4.     myPath = ThisWorkbook.Path & ""
   
5.     arr = Range("X2:AE33")
   
6.     Set fs = CreateObject("Scripting.FileSystemObject")
   
7. 
   
8.     For i = 1 To UBound(arr)
   
9.         If fs.FolderExists(myPath & i) Then  '文件夹是否存在
   
10.             fs.DeleteFolder (myPath & i)     '删除文件夹
    
11.         End If
    
12.     Next
    
13.     For i = 1 To UBound(arr)
    
14.         m = 0
    
15.         For j = 1 To UBound(arr, 2)
    
16.             If Not IsError(arr(i, j)) Then   '判断是否为错误值
    
17.             s = Trim(arr(i, j))
    
18.                 If IsNumeric(Left(s, 1)) And Len(s) > 0 Then '判断是否为数值且不为空
    
19.                     m = m + 1                        '计算
    
20.                     If m = 1 Then fs.CreateFolder (myPath & i)       '创建文件夹
    
21.                     Set f = fs.CreateTextfile(myPath & i & "" & m & ".txt", True) '创建文本
    
22.                     f.write s      '写入
    
23.                     f.Close        '关闭
    
24.                 End If
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     MsgBox "完成!!"
    
29. End Sub
    

复制代码

附件：
请教导出问题.zip (15.33 KB, 下载次数: 11)

2015-1-27 17:23 上传

点击文件名下载附件

跳转到最佳答案楼层

yvll

请求帮助

芐雨

yvll 发表于 2015-1-26 16:52
请求帮助

取少量数据，模拟下结果，让别人好理解，以便更好解决问题啊

yvll

原附件写的不够清楚 ，再重新上传一个。
请教导出问题 (1).rar (7.48 KB, 下载次数: 4)

2015-1-27 15:59 上传

点击文件名下载附件

芐雨

1. Sub t()
   
2.     Dim arr, i&, j&, s, m%
   
3.     Dim myPath, fs, f
   
4.     myPath = ThisWorkbook.Path & ""
   
5.     arr = Range("X2:AE33")
   
6.     Set fs = CreateObject("Scripting.FileSystemObject")
   
7. 
   
8.     For i = 1 To UBound(arr)
   
9.         If fs.FolderExists(myPath & i) Then  '文件夹是否存在
   
10.             fs.DeleteFolder (myPath & i)     '删除文件夹
    
11.         End If
    
12.     Next
    
13.     For i = 1 To UBound(arr)
    
14.         m = 0
    
15.         For j = 1 To UBound(arr, 2)
    
16.             If Not IsError(arr(i, j)) Then   '判断是否为错误值
    
17.             s = Trim(arr(i, j))
    
18.                 If IsNumeric(Left(s, 1)) And Len(s) > 0 Then '判断是否为数值且不为空
    
19.                     m = m + 1                        '计算
    
20.                     If m = 1 Then fs.CreateFolder (myPath & i)       '创建文件夹
    
21.                     Set f = fs.CreateTextfile(myPath & i & "" & m & ".txt", True) '创建文本
    
22.                     f.write s      '写入
    
23.                     f.Close        '关闭
    
24.                 End If
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     MsgBox "完成!!"
    
29. End Sub
    

复制代码

附件：
请教导出问题.zip (15.33 KB, 下载次数: 11)

2015-1-27 17:23 上传

点击文件名下载附件

yvll

芐雨 发表于 2015-1-27 17:23
附件：

太好了，方方面面都考虑到了，太专业了，代码写的漂亮。非常非常感谢您，等回家放在实际的程序上试试再来。

yvll

芐雨 发表于 2015-1-27 17:23
附件：

刚到家，在实际程序上应用的非常好，再次感谢您！

yvll

芐雨 发表于 2015-1-27 17:23
附件：

您好，能否帮助我将导出的文本文件内的数字由横排改为1列竖排，每个数字后面不要有空格。例如
01
02
03
。。
谢谢您！

芐雨

yvll 发表于 2015-2-2 16:21
您好，能否帮助我将导出的文本文件内的数字由横排改为1列竖排，每个数字后面不要有空格。例如
01
02

Sub t()
    Dim arr, i&, j&, s$, m%
    Dim myPath$, fs, f
    myPath = ThisWorkbook.Path & "\"
    arr = Range("X2:AE33")
    Set fs = CreateObject("Scripting.FileSystemObject")
    For i = 1 To UBound(arr)
        If fs.FolderExists(myPath & i) Then  '文件夹是否存在
            fs.DeleteFolder (myPath & i)     '删除文件夹
        End If
    Next
    For i = 1 To UBound(arr)
        m = 0
        For j = 1 To UBound(arr, 2)
            If Not IsError(arr(i, j)) Then   '判断是否为错误值
                s = Replace(Trim(arr(i, j)), " ", vbCrLf)
                If IsNumeric(Left(s, 1)) And Len(s) > 0 Then    '判断是否为数值且不为空
                    m = m + 1                        '计算
                    If m = 1 Then fs.CreateFolder (myPath & i)       '创建文件夹
                    Set f = fs.CreateTextfile(myPath & i & "\" & m & ".txt", True)    '创建文本
                    f.write s    '写入
                    f.Close        '关闭
                End If
            End If
        Next
    Next
    MsgBox "完成!!"
End Sub

yvll

芐雨 发表于 2015-2-2 16:49
Sub t()
    Dim arr, i&, j&, s$, m%
    Dim myPath$, fs, f

太好了，万分感谢您！