(求助)工作簿指定名称表汇总

231943361

工作簿指定名称表汇总
(已经编辑部分VBA,下面的循环堵住了,或者可以重新帮忙写个新的VBA)
希望伟大的坛友出手相助

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Dim d As Object
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   Set d1 = CreateObject("scripting.dictionary")
   
10.   With Worksheets("统计汇总")
    
11.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
12.     arr = .Range("c2").Resize(1, c - 2)
    
13.   End With
    
14.   For j = 1 To UBound(arr, 2) Step 2
    
15.     If Len(arr(1, j)) <> 0 Then
    
16.       d1(arr(1, j)) = j + 1
    
17.     End If
    
18.   Next
    
19.   ReDim brr(1 To 1000, 1 To UBound(arr, 2) + 2)
    
20.   m = 0
    
21.   mypath = ThisWorkbook.Path & "\一个工作簿存在多个表--- 汇总汇总表001"
    
22.   myname = Dir(mypath & "*.xlsx")
    
23.   Do While myname <> ""
    
24.     If myname <> ThisWorkbook.Name Then
    
25.       Set wb = GetObject(mypath & myname)
    
26.       With wb
    
27.         With .Worksheets("汇总")
    
28.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
29.           arr = .Range("a3:e" & r)
    
30.           m = m + 1
    
31.           brr(m, 1) = arr(1, 2)
    
32.           For i = 4 To UBound(arr)
    
33.             If d1.exists(arr(i, 1)) Then
    
34.               n = d1(arr(i, 1))
    
35.               brr(m, n) = arr(i, 4)
    
36.               brr(m, n + 1) = arr(i, 5)
    
37.             End If
    
38.           Next
    
39.         End With
    
40.         .Close False
    
41.       End With
    
42.     End If
    
43.     myname = Dir
    
44.   Loop
    
45.   With Worksheets("统计汇总")
    
46.     .Range("b3").Resize(m, UBound(brr, 2)) = brr
    
47.   End With
    
48. End Sub
    

复制代码

chxw68

详见附件。

231943361

chxw68 发表于 2018-7-12 11:01
详见附件。

我对老师的敬仰之情,犹如滔滔江水,绵延不绝

感谢老师的孜孜不倦 感谢

opiona

http://club.excelhome.net/thread-1409141-1-1.html

231943361

'=======================================================================
'03 递归后调用 统计
'=======================================================================
Sub jsjs汇总统计()
    Application.ScreenUpdating = False
    Dim i, i3, i6 As Long
    ReDim brr(1 To 10, 1 To 23)
    Dim SourceBook As Workbook
    Dim SourceSheet As Worksheet
    Dim ws As Worksheet
   '将对象引用赋给变量或属性。
    Set ws = Worksheets("统计汇总")
    'Set ws2 = Worksheets("汇总")
    '清空结果表
    'ThisWorkbook.Sheets("结果表").Range("a2:ci" & Sheets("结果表").UsedRange.Rows.Count).Clear
    '给变量赋值
    i6 = 3
    k = 1
   ' i2 = 2
    '判断是否导入文件
    If Len(Trim(ws.Cells(3, 25))) = 0 Then
       MsgBox ("请导入目标所在的文件夹!")
      Exit Sub
    End If
    Do
        If Len(Trim(ws.Cells(i6, 25))) = 0 Then Exit Do
        'Dim SourceBook As Workbook  打开导入的文件夹根路径下的文件
        Set SourceBook = Workbooks.Open(Trim(ws.Cells(i6, 25)), False) 'Open 打开一个工作簿
        'Dim SourceSheet As Worksheet 遍历打开的文件夹下的文件
        For Each SourceSheet In SourceBook.Worksheets
            '**************************************************************
            'If SourceSheet.Name <> "汇总" And SourceSheet.[B3] <> "" Then Else On Error GoTo ERROR1
            If Left(SourceSheet.Name, 2) <> "汇总" Then Else On Error GoTo ERROR1
            
            '**************************************************************
                    'If Len(SourceSheet.[b8]) <> 0 Then i3 = True Else On Error GoTo ERROR1
                    i3 = True
                    '激活文件夹
                    'SourceSheet.Activate
                    Do While i3
                        '返回 Long，其中包含字符串内字符的数目，或是存储一变量所需的字节数。
                        '窗口表的品名项 看是不是为空
                        'If Len(Trim(SourceSheet.Cells(i3, 1))) = 0 Then Exit Do
                        
                            'r = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
                            'If SourceSheet.[B3] <> "" Then
                            brr(k, 1) = SourceSheet.[B3] '模具号4
                           
                            'arr = SourceSheet.Range("a6:e" & r)
                            arr = SourceSheet.Range("a6:e" & 16)
                                For i = 1 To UBound(arr)
                                    If arr(i, 1) <> "" Then
                                        'n = n + 1
                                        'k = 3
                                        For n = 1 To 11
                                            If n = 1 Then
                                                brr(k, 2) = arr(n, 4) '件号6
                                                brr(k, 3) = arr(n, 5) '件号6
                                            End If
                                            If n = 2 Then
                                                brr(k, 4) = arr(n, 4) '件号6
                                                brr(k, 5) = arr(n, 5) '件号6
                                            End If
                                            If n = 3 Then
                                                brr(k, 6) = arr(n, 4) '件号6
                                                brr(k, 7) = arr(n, 5) '件号6
                                            End If
                                            If n = 4 Then
                                                brr(k, 8) = arr(n, 4) '件号6
                                                brr(k, 9) = arr(n, 5) '件号6
                                            End If
                                            If n = 5 Then
                                                brr(k, 10) = arr(n, 4) '件号6
                                                brr(k, 11) = arr(n, 5) '件号6
                                            End If
                                            If n = 6 Then
                                                brr(k, 12) = arr(n, 4) '件号6
                                                brr(k, 13) = arr(n, 5) '件号6
                                            End If
                                            If n = 7 Then
                                                brr(k, 14) = arr(n, 4) '件号6
                                                brr(k, 15) = arr(n, 5) '件号6
                                            End If
                                            If n = 8 Then
                                                brr(k, 16) = arr(n, 4) '件号6
                                                brr(k, 17) = arr(n, 5) '件号6
                                            End If
                                            If n = 9 Then
                                                brr(k, 18) = arr(n, 4) '件号6
                                                brr(k, 19) = arr(n, 5) '件号6
                                            End If
                                            If n = 10 Then
                                                brr(k, 20) = arr(n, 4) '件号6
                                                brr(k, 21) = arr(n, 5) '件号6
                                            End If
                                            If n = 11 Then
                                                brr(k, 22) = arr(n, 4) '件号6
                                                brr(k, 23) = arr(n, 5) '件号6
                                            End If
                                            '错误模板
'                                            If n = 11 And Len(SourceSheet.[a16]) = "扬州" Then
'                                                brr(k, 22) = arr(n, 4) '件号6
'                                                brr(k, 23) = arr(n, 5) '件号6
'                                            End If

                                         Next n
                                       
                                       
                                        End If
                                       
                                       
                                    Next i
                                    i3 = False
                               ' End If
                        Loop
            
            Next
             SourceBook.Close False
             Set SourceSheet = Nothing
             i6 = i6 + 1
             k = k + 1
    Loop
   
        Sheet1.[B3].Resize(k, 23) = brr '将数据表数据放入brr数组,在将brr数组赋值给查询表
        j = 1
        MsgBox ("汇总完成")
ERROR1:
        ' MsgBox "表格不能为空"
        Application.ScreenUpdating = True
End Sub

为什么我这句判断是否是汇总表没有用呢?

231943361

'**************************************************************
            'If SourceSheet.Name <> "汇总" And SourceSheet.[B3] <> "" Then Else On Error GoTo ERROR1
            If Left(SourceSheet.Name, 2) <> "汇总" Then Else On Error GoTo ERROR1
    就是这一句,为什么判断没有用呀

LMY123

字典，多薄