excel多工作簿汇总至同一工作表[代码已有，求完善]

捞屎人

代码已经有了（见附件） 可以实现多工作表汇总，但是如何把每个工作表的表头去掉，另外如何把多余的空行也跳过（用姓名列判断，姓名列为空则判断为表格数据结束），用姓名求大牛帮忙

jiminyanyan

1. Sub vba入门jimin()
   
2. '扣扣494585639
   
3.     Dim MyPath$, MyName$, sh As Worksheet
   
4.     Dim brr(1 To 60000, 1 To 6)
   
5.     Application.ScreenUpdating = False
   
6.     Set sh = ActiveSheet
   
7.     Cells.Clear
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyName = Dir(MyPath & "*.xls*")
   
10.     Do While MyName <> ""
    
11.         If MyName <> ThisWorkbook.Name Then
    
12.             With GetObject(MyPath & MyName)
    
13.                 m = m + 1
    
14.                 If m = 1 Then
    
15.                     arr = .Sheets("sheet1").Range("a1:f" & .Sheets("sheet1").Range("b65535").End(xlUp).Row)
    
16.                     For i = 1 To UBound(arr)
    
17.                         k = k + 1
    
18.                         For j = 1 To UBound(arr, 2)
    
19.                             brr(k, j) = arr(i, j)
    
20.                         Next
    
21.                     Next
    
22.                 Else
    
23.                      arr = .Sheets("sheet1").Range("a1:f" & .Sheets("sheet1").Range("b65535").End(xlUp).Row)
    
24.                     For i = 2 To UBound(arr)
    
25.                         k = k + 1
    
26.                         For j = 1 To UBound(arr, 2)
    
27.                             brr(k, j) = arr(i, j)
    
28.                         Next
    
29.                     Next
    
30.                 End If
    
31.                 .Close False
    
32.             End With
    
33.         End If
    
34.         MyName = Dir
    
35.     Loop
    
36.     Sheet1.Range("a1:f60000").ClearContents
    
37.     Sheet1.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
38.     Application.ScreenUpdating = True
    
39. End Sub

复制代码

jiminyanyan

………………。

乐乐2006201505

试试，应该好了，你的高三20班的工作簿怎么打不开，就是那个工作簿有些问题。

好奇怪，怎么明明刷新了几次，都没有发现有回复，所以上传的，为什么上传后却发现有解答的帖子……

xiangbaoan

Sub 汇总数据()
Application.ScreenUpdating = False
Dim myPath$, myFile$, arr, r&
ThisWorkbook.Worksheets(1).UsedRange.Offset(1).Clear
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
    If myFile <> ThisWorkbook.Name Then
        With GetObject(myPath & myFile)
            With .Worksheets(1)
                r = .Cells(.Rows.Count, 2).End(xlUp).Row
                arr = .Range("a2:f" & r)
            End With
            .Close False
        End With
        With ThisWorkbook.Worksheets(1)
            r = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
            .Range("a" & r).Resize(UBound(arr), UBound(arr, 2)) = arr
        End With
    End If
    myFile = Dir
Loop
ThisWorkbook.Worksheets(1).Range("a1:f" & Cells(Rows.Count, 1).End(xlUp).Row).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
'补上附件

捞屎人

谢谢各位热心的大牛，

jiminyanyan

xiangbaoan 发表于 2017-3-15 20:50
Sub 汇总数据()
Application.ScreenUpdating = False
Dim myPath$, myFile$, arr, r&

该代码标题要事先写好…………。

乐乐2006201505

xiangbaoan 发表于 2017-3-15 20:50
Sub 汇总数据()
Application.ScreenUpdating = False
Dim myPath$, myFile$, arr, r&

这个代码很好，就是没有表头。

jjmysjg

公式太复杂，不能指定到对象上
求解