[已解决]请老师及高手们帮助修改个代码

dfzc

本表中的“导入”代码是自选路径导入，怎么修改下代码当运行“导入”程序时能直接从本文件夹中的“结果”文件夹中自动全部选中并导入，请老师或高手们帮忙给解决下，谢谢
导入测试.rar (105.08 KB, 下载次数: 7)

2012-10-22 09:30 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

suye1010

2012-10-22 09:53

1. Private Sub CommandButton1_Click()
   
2. [d2:ho3].ClearContents: [d6:iv60000].ClearContents
   
3.     Application.ScreenUpdating = False
   
4.     Dim txt As Object, TextLine As String, Fn As Variant, b() As Byte
   
5.     filepath = ThisWorkbook.Path & Application.PathSeparator & "结果" & Application.PathSeparator
   
6.     Fn = Dir(filepath)
   
7.     Do While Fn <> ""
   
8.         n = n + 1
   
9.         Cells(3, n + 3) = Left(Fn, InStr(Fn, ".") - 1)
   
10.         Open filepath & Fn For Input As #1
    
11.         arr = Split(Replace(Replace(Replace(StrConv(InputB$(LOF(1), 1), vbUnicode), " ", ","), vbCrLf, ","), ",,", ","), ",")
    
12.         Close #1
    
13.         Cells(6, n + 3).Resize(UBound(arr), 1) = WorksheetFunction.Transpose(arr)
    
14.         Cells(2, n + 3) = UBound(arr)
    
15.         Fn = Dir
    
16.     Loop
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. ChDir ThisWorkbook.Path & "\结果"

复制代码

suye1010

1. Private Sub CommandButton1_Click()
   
2. [d2:ho3].ClearContents: [d6:iv60000].ClearContents
   
3.     Application.ScreenUpdating = False
   
4.     Dim txt As Object, TextLine As String, Fn As Variant, b() As Byte
   
5.     filepath = ThisWorkbook.Path & Application.PathSeparator & "结果" & Application.PathSeparator
   
6.     Fn = Dir(filepath)
   
7.     Do While Fn <> ""
   
8.         n = n + 1
   
9.         Cells(3, n + 3) = Left(Fn, InStr(Fn, ".") - 1)
   
10.         Open filepath & Fn For Input As #1
    
11.         arr = Split(Replace(Replace(Replace(StrConv(InputB$(LOF(1), 1), vbUnicode), " ", ","), vbCrLf, ","), ",,", ","), ",")
    
12.         Close #1
    
13.         Cells(6, n + 3).Resize(UBound(arr), 1) = WorksheetFunction.Transpose(arr)
    
14.         Cells(2, n + 3) = UBound(arr)
    
15.         Fn = Dir
    
16.     Loop
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

hwc2ycy

suye1010 发表于 2012-10-22 09:53

Application.PathSeparator

这个好。