请高手看这个超难度的vba问题

guandu

我附件中一共有4个表，我希望在工资汇总表中当我选择汇总窗体的时候，他会在附件中每个单位的职工工资中找出相同的数据填入工资汇总表中对应的位置中，例如工资汇总表中各个就是我所希望达到的结果，谢谢各位高手的帮忙。

zhaogang1960

有点难度，不知道窗体是什么样子，先试试看：
Sub Macro1()
    Dim MyPath$, MyName$, sh As Worksheet, d As Object
    Dim ary(1 To 4), arr, brr(1 To 4), crr(1 To 22, 2 To 16), i&, j&, m&
    Set d = CreateObject("scripting.dictionary")
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Range("B5:P26").ClearContents
        m = m + 1
        d(sh.Name) = m
        brr(m) = crr
    Next
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                arr = .Sheets(1).[a1].CurrentRegion
                .Close False
            End With
            For i = 4 To UBound(arr)
                If d.Exists(arr(i, 1)) Then
                    m = d(arr(i, 1))
                    ary(m) = ary(m) + 1
                    For j = 2 To 16
                        brr(m)(ary(m), j) = arr(i, j)
                    Next
                End If
            Next
        End If
        MyName = Dir
    Loop
    For Each sh In Sheets
        sh.[b5].Resize(ary(d(sh.Name)), 15) = brr(d(sh.Name))
    Next
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

zhaogang1960

附件
新建文件夹.rar (17.16 KB, 下载次数: 15)

2011-3-16 23:56 上传

点击文件名下载附件

guandu

2zhaogang1960师傅您好，谢谢您的代码，但因本人水平有限，把这个代码写入我所需要的文档中就出现错误，我改了半天都不知道是哪里出错，能否再请您帮忙看下，谢谢您的帮忙
因文件过大，所以分4个文件上传，4个文件集中在一个文件夹中的

zhaogang1960

原帖由 guandu 于 2011-3-17 09:32 发表
2zhaogang1960师傅您好，谢谢您的代码，但因本人水平有限，把这个代码写入我所需要的文档中就出现错误，我改了半天都不知道是哪里出错，能否再请您帮忙看下，谢谢您的帮忙
因文件过大，所以分4个文件上传，4个文件集 ...

Sub Macro1()
    Dim MyPath$, MyName$, sh As Worksheet, d As Object
    Dim ary(1 To 4), arr, brr(1 To 4), crr(1 To 22, 2 To 16), i&, j&, m&
    Set d = CreateObject("scripting.dictionary")
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Range("B5:P26").ClearContents
        m = m + 1
        d(sh.Name) = m
        brr(m) = crr
    Next
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                With .Sheets("保存")
                    .Unprotect "321"
                    arr = .[a1].CurrentRegion
                End With
                .Close False
            End With
            For i = 4 To UBound(arr) - 1
                If d.Exists(arr(i, 1)) Then
                    m = d(arr(i, 1))
                    ary(m) = ary(m) + 1
                    For j = 2 To 16
                        brr(m)(ary(m), j) = arr(i, j)
                    Next
                End If
            Next
        End If
        MyName = Dir
    Loop
    For Each sh In Sheets
        sh.[b5].Resize(ary(d(sh.Name)), 15) = brr(d(sh.Name))
    Next
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

zhaogang1960

附件
新建文件夹.rar (305.79 KB, 下载次数: 54)

2011-3-17 10:46 上传

点击文件名下载附件

guandu

谢谢zhaogang1960师傅，您的代码正是我所希望的，再次万分感激您的帮忙。