[已解决]麻烦各位帮我看看这代码怎么修改哈

541181001

我想把一个文件夹下所有的工作表第一个表的数据粘贴到汇总表中，可是运行代码只能粘贴其中一个表，不知道什么原因，麻烦大家帮我看看哈，先谢过!

最佳答案

月排行榜 / 总排行榜

liyh67

2014-6-19 17:40

将k = 1移到Do While f <> ""后面

1. Sub 汇总()
   
2. Dim r&, k&
   
3. Application.ScreenUpdating = False
   
4. f = Dir(ThisWorkbook.Path & "\*.xls")
   
5. Do While f <> ""
   
6. k = 1
   
7. If f <> ThisWorkbook.Name Then
   
8. Workbooks.Open (ThisWorkbook.Path & "" & f)
   
9. Set th = ThisWorkbook.Worksheets("汇总")
   
10. Set ac = ActiveWorkbook.Worksheets("新目录")
    
11. 10:
    
12. k = k + 1
    
13. If ac.Cells(k, 1) <> "" Then
    
14. r = th.Cells(th.Cells.Rows.Count, 1).End(xlUp).Row + 1
    
15. th.Cells(r, 1) = ac.Cells(k, 1)
    
16. th.Cells(r, 2) = ac.Cells(k, 2)
    
17. th.Cells(r, 3) = ac.Cells(k, 3)
    
18. GoTo 10
    
19. Else
    
20. ActiveWorkbook.Close 0
    
21. End If
    
22. End If
    
23. f = Dir
    
24. Loop
    
25. Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

跳转到最佳答案楼层

liyh67

将k = 1移到Do While f <> ""后面

1. Sub 汇总()
   
2. Dim r&, k&
   
3. Application.ScreenUpdating = False
   
4. f = Dir(ThisWorkbook.Path & "\*.xls")
   
5. Do While f <> ""
   
6. k = 1
   
7. If f <> ThisWorkbook.Name Then
   
8. Workbooks.Open (ThisWorkbook.Path & "" & f)
   
9. Set th = ThisWorkbook.Worksheets("汇总")
   
10. Set ac = ActiveWorkbook.Worksheets("新目录")
    
11. 10:
    
12. k = k + 1
    
13. If ac.Cells(k, 1) <> "" Then
    
14. r = th.Cells(th.Cells.Rows.Count, 1).End(xlUp).Row + 1
    
15. th.Cells(r, 1) = ac.Cells(k, 1)
    
16. th.Cells(r, 2) = ac.Cells(k, 2)
    
17. th.Cells(r, 3) = ac.Cells(k, 3)
    
18. GoTo 10
    
19. Else
    
20. ActiveWorkbook.Close 0
    
21. End If
    
22. End If
    
23. f = Dir
    
24. Loop
    
25. Application.ScreenUpdating = True
    
26. End Sub
    

复制代码