在线求助各位老师如何汇总各附件工作簿指定工作表的相应数据到另一个新工作簿

qinhuan66

求助如何从各个附件工作簿中的《绩效发放明细打印》表中提取数据到汇总表的相应单元格内。谢谢
各表格汇总.rar (238.7 KB, 下载次数: 11)

2018-9-18 08:23 上传

点击文件名下载附件

microyip

论坛很多这种汇总，学习参考一下代码即可实现

qinhuan66

朱荣兴 发表于 2018-9-18 10:07
仅仅供参考
Sub 汇总()
Application.ScreenUpdating = False

老师!为什么我这条代码会出错呢？请指教

1. Sub 汇总数据()
   
2.     Application.ScreenUpdating = False
   
3.     Dim brr(1 To 10000, 1 To 31)
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = Dir(p & "*.xls*")
   
6.     Do While f <> ""
   
7.         If f <> ThisWorkbook.Name Then
   
8.             With Workbooks.Open(p & f)
   
9.                 arr = .Sheets(2).UsedRange
   
10.                 .Close 0
    
11.             End With
    
12.             For i = 14 To UBound(arr)
    
13.                 If IsNumeric(arr(i, 1)) And Len(arr(i, 2)) Then
    
14.                     m = m + 1
    
15.                     brr(m, 1) = m
    
16.                     brr(m, 2) = arr(3, 5)
    
17.                     brr(m, 3) = arr(3, 31)
    
18.                     For j = 2 To UBound(arr, 2)
    
19.                         brr(m, j + 1) = arr(i, j)
    
20.                     Next
    
21.                 End If
    
22.            Next
    
23.        End If
    
24.        f = Dir
    
25.     Loop
    
26.     If m > 0 Then
    
27.         [a1].CurrentRegion.Offset(1).Clear
    
28.         [a2].Resize(m, 31) = brr
    
29.         [a2].Resize(m, 31).Borders.LineStyle = 1
    
30.     End If
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码

LMY123

qinhuan66 发表于 2018-9-18 14:58
老师!为什么我这条代码会出错呢？请指教

你试一下ubound(arr,2)和ubound(brr,2)就明白了

lsc900707

qinhuan66 发表于 2018-9-18 14:58
老师!为什么我这条代码会出错呢？请指教

Sub 汇总数据()
    Application.ScreenUpdating = False
    Dim brr(1 To 10000, 1 To 31)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            With Workbooks.Open(p & f)
                arr = .Sheets(2).UsedRange
                .Close 0
            End With
            For i = 14 To UBound(arr)
                If Len(arr(i, 1)) And IsNumeric(arr(i, 1)) Then
                    m = m + 1
                    brr(m, 1) = arr(3, 5)
                    brr(m, 2) = arr(3, 31)
                    brr(m, 3) = arr(i, 2)
                    For j = 4 To 31
                        brr(m, j) = arr(i, j)
                    Next
                End If
           Next
       End If
       f = Dir
    Loop
    If m > 0 Then
        [a1].CurrentRegion.Offset(1).Clear
        [a2].Resize(m, 31) = brr
        [a2].Resize(m, 31).Borders.LineStyle = 1
    End If
    Application.ScreenUpdating = True
End Sub

lsc900707

qinhuan66 发表于 2018-9-18 14:58
老师!为什么我这条代码会出错呢？请指教

你的代码稍加修改就可以的：