[已解决]如何汇总所有工作簿固定行到新建工作簿从第12行开始，往后移动6行，一直到没有内容...

Trunk

如何汇总文件夹中所有工作簿固定行到新建工作簿，从第12行开始，往后移动6行，一直到没有内容为止

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-11 17:02

没调输出格式，自己搞定吧。

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim arr(1 To 10000, 1 To 10)
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets(1)
    
11.             For i = 1 To Sht.[a65536].End(3).Row
    
12.                 If Sht.Cells(i, 1) = "客户品名" And Len(Sht.Cells(i, 1)) Then
    
13.                     n = n + 1
    
14.                     arr(n, 1) = Filename
    
15.                     For j = 1 To 9
    
16.                         arr(n, j + 1) = Sht.Cells(i + 1, j)
    
17.                     Next
    
18.                 End If
    
19.             Next
    
20.             wb.Close False
    
21.         End If
    
22.         Filename = Dir
    
23.     Loop
    
24.     Set Sht = Nothing
    
25.     For i = UBound(arr) To 2 Step -1
    
26.         If arr(i, 1) = arr(i - 1, 1) Then arr(i, 1) = ""
    
27.     Next
    
28.     [a1].Resize(n, 10) = arr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

跳转到最佳答案楼层

grf1973

没调输出格式，自己搞定吧。

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim arr(1 To 10000, 1 To 10)
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets(1)
    
11.             For i = 1 To Sht.[a65536].End(3).Row
    
12.                 If Sht.Cells(i, 1) = "客户品名" And Len(Sht.Cells(i, 1)) Then
    
13.                     n = n + 1
    
14.                     arr(n, 1) = Filename
    
15.                     For j = 1 To 9
    
16.                         arr(n, j + 1) = Sht.Cells(i + 1, j)
    
17.                     Next
    
18.                 End If
    
19.             Next
    
20.             wb.Close False
    
21.         End If
    
22.         Filename = Dir
    
23.     Loop
    
24.     Set Sht = Nothing
    
25.     For i = UBound(arr) To 2 Step -1
    
26.         If arr(i, 1) = arr(i - 1, 1) Then arr(i, 1) = ""
    
27.     Next
    
28.     [a1].Resize(n, 10) = arr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

Trunk

grf1973 发表于 2015-12-11 17:02
没调输出格式，自己搞定吧。

完美解决了我的问题，谢谢大神