[已解决]如何给宏代码加入循环语句

lijian8003

下述代码将z1.txt数据导入excel的a1:u300
欲将z2.txt数据导入excel的a301:u600，需要再写一个类似的宏代码
如果有z1...z300.txt依次导入，就要写300个类似的宏代码
能否加个循环语句，解决上述问题？

Sub 导入数据()
    Sheets("数据").Select
    Application.ScreenUpdating = False
    Range("a1:u300").ClearContents
    With Workbooks.Open("D:\数据\z1.txt")
        .ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.ActiveSheet.Range("a1")
        .Close False
    End With
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-10-26 23:21

lijian8003 发表于 2013-10-26 23:17
With Application.FileSearch
就是这一句

把代码改成下面的试试：
附件如下，请测试：
(, 下载次数: 3)

上传

点击文件名下载附件

1. Sub 导入数据()
   
2.     Dim i&, j&, k&, s as string
   
3.     ThisWorkbook.Sheets(2).Columns("a:u").ClearContents
   
4.     Application.ScreenUpdating = False
   
5.    s = Dir(ThisWorkbook.Path & "\*.txt")
   
6.      Do While s <> ""
   
7.      i = i + 1
   
8.      s = Dir
   
9.      Loop
   
10.     k = 1
    
11. For j = 1 To i
    
12.     With Workbooks.Open("D:\数据\z" & j & ".txt")
    
13.         .ActiveSheet.Range("A1:u300").Copy ThisWorkbook.Sheets(2).Range("a" & k)
    
14.         .Close False
    
15.     End With
    
16.     k = k + 300
    
17.     Next j
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

我心飞翔410

Sub 导入数据()
Dim i As Integer
    Sheets("数据").Select
    Application.ScreenUpdating = False
    Range("a1:u300").ClearContents
    For i = 1 To 300
    With Workbooks.Open("D:\数据\z" & i & ".txt")
        .ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.ActiveSheet.Range("a1")
        .Close False
    End With
    Next i
    Application.ScreenUpdating = True
End Sub

danio112

试试这个
Sub 导入数据()
    Sheets("数据").Select
    Application.ScreenUpdating = False
    Range(Cells(1, 1), Cells(300, 90000)).ClearContents
   
    Dim k As Integer
    k = 1
   
    For i = 1 To 300
    With Workbooks.Open("D:\数据\z" & i & ".txt")
        .ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.ActiveSheet.Cells(1, k)
        k = k + 300
        .Close False
    End With
    Next
    Application.ScreenUpdating = True
End Sub

yyyydddd8888

请测试下面的代码：
附件如下：
数据.zip (15.95 KB, 下载次数: 5)

2013-10-26 22:34 上传

点击文件名下载附件

1. Sub 导入数据()
   
2.     Dim i&, j&, k&
   
3.     ThisWorkbook.Sheets(2).Columns("a:u").ClearContents
   
4.     Application.ScreenUpdating = False
   
5.     With Application.FileSearch
   
6.       .NewSearch
   
7.       .LookIn = "d:\数据"
   
8.       .Filename = "*.txt"
   
9.       .Execute
   
10.       i = .FoundFiles.Count
    
11.     End With
    
12.     k = 1
    
13. For j = 1 To i
    
14.     With Workbooks.Open("D:\数据\z" & j & ".txt")
    
15.         .ActiveSheet.Range("A1:u300").Copy ThisWorkbook.Sheets(2).Range("a" & k)
    
16.         .Close False
    
17.     End With
    
18.     k = k + 300
    
19.     Next j
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

lijian8003

我心飞翔410 发表于 2013-10-26 21:33
Sub 导入数据()
Dim i As Integer
    Sheets("数据").Select

.ActiveSheet.Range("A1").CurrentRegion.Copy ThisWorkbook.ActiveSheet.Range("a1")
这句不需要改变吗？

lijian8003

yyyydddd8888 发表于 2013-10-26 22:31
请测试下面的代码：
附件如下：

With Application.FileSearch
   对象不支持该动作

yyyydddd8888

lijian8003 发表于 2013-10-26 22:54
With Application.FileSearch
   对象不支持该动作

不会呀，我在我的电脑上测试过的啊！能取出数据的啊！

lijian8003

yyyydddd8888 发表于 2013-10-26 22:56
不会呀，我在我的电脑上测试过的啊！能取出数据的啊！

运行时错误'445'对象不支持该操作
我是WIN7 64位，excel64位，与之有关吗？

yyyydddd8888

lijian8003 发表于 2013-10-26 23:06
运行时错误'445'对象不支持该操作
我是WIN7 64位，excel64位，与之有关吗？

我也不清楚，我是xp 的系统，excel2003
你在出错的提示框中点一下调试按钮，看看出错的是哪一句代码，再告诉我，我再看看。

lijian8003

yyyydddd8888 发表于 2013-10-26 22:56
不会呀，我在我的电脑上测试过的啊！能取出数据的啊！

VBA Excel 2007 Application.FileSearch 替代方法
http://www.cnblogs.com/Nina-piaoye/archive/2013/04/09/3010310.html