用字典把不等列多个工作簿合并和汇总

qdchyq

求助2.zip (23.22 KB, 下载次数: 242)

2011-10-1 21:49 上传

点击文件名下载附件

Private Sub CommandButton1_Click()
    Dim i As Integer, k As Integer, r As Integer
    Dim w As Integer, sh As Worksheet
    Dim d As Object, arr(), arr2()
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            For i = 1 To sh.Range("iv1").End(xlToLeft).Column - 1
                If Not d.exists(sh.Cells(1, i).Value) Then
                    s = s + 1
                    d(sh.Cells(1, i).Value) = s
                End If
            Next
        End If
    Next
    s = s + 1
    d("合计") = s'可能错在此处，请老师帮忙修改一下
    With UserForm1.ListView1
        For j = 1 To .ListItems.Count
            If .ListItems(j).Checked = True Then
                With Sheets(.ListItems(j).Text)
                    r = .Range("a65536").End(xlUp).Row
                    If r > 1 Then
                        ar = .Range("a1").Resize(r, s)
                        For i = 2 To UBound(ar)
                            k = k + 1
                            ReDim Preserve arr(1 To s, 1 To k)
                            For w = 1 To UBound(ar, 2)
                                If ar(1, w) <> "" Then arr(d(ar(1, w)), k) = ar(i, w)
                            Next
                        Next
                    End If
                End With
            End If
        Next
    End With
    If UserForm1.OptionButton1.Value = True Then
        With Sheets("汇总")
            .Cells.ClearContents
            If SafeArrayGetDim(arr) = 0 Then Exit Sub
            .Range("a1").Resize(1, s) = d.Keys
            .Range("a2").Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)   '这一段是合并
        End With
    Else
        With Sheets("汇总")
            If SafeArrayGetDim(arr) = 0 Then Exit Sub
            .Cells.ClearContents
            .Range("a1").Resize(1, UBound(arr)) = d.Keys
            d.RemoveAll
            k = 0
            For i = 1 To UBound(arr, 2)
                If Not d.exists(arr(1, i)) Then
                    k = k + 1
                    d(arr(1, i)) = k
                    ReDim Preserve arr2(1 To UBound(arr), 1 To k)
                    For w = 1 To UBound(arr)
                        arr2(w, d(arr(1, i))) = arr(w, i)
                    Next
                Else
                    For w = 2 To UBound(arr)
                        arr2(w, d(arr(1, i))) = arr2(w, d(arr(1, i))) + arr(w, i)
                    Next
                End If
            Next
            .Range("a2").Resize(UBound(arr2, 2), UBound(arr2)) = Application.Transpose(arr2)  '这一段是汇总
        End With
    End If
End Sub

mjzxlmg

把：
s = s + 1
    d("合计") = s'可能错在此处，请老师帮忙修改一下

改为
Sheets("汇总").[a1].Resize(1, s) = d.keys

qdchyq

mjzxlmg 发表于 2011-10-1 23:10
把：
s = s + 1
    d("合计") = s'可能错在此处，请老师帮忙修改一下

谢谢！老师帮忙

mjzxlmg

qdchyq 发表于 2011-10-1 23:14
谢谢！老师帮忙

另外这句： For i = 1 To sh.Range("iv1").End(xlToLeft).Column - 1
似乎不用－1吧，
这句是查找标题列数，有了－1，业务8就不能复制到汇总工作表
下面的红色的语句添加了一处判断，汇总时就不出现烦人的0

               Else
                    For w = 2 To UBound(arr)
                     If arr(w, i) <> "" Then
                        arr2(w, d(arr(1, i))) = arr2(w, d(arr(1, i))) + arr(w, i)
                     End If
                    Next
                End If
            Next
            .Range("a2").Resize(UBound(arr2, 2), UBound(arr2)) = Application.Transpose(arr2)  '这一段是汇总

mjzxlmg

完整语句：
Private Sub CommandButton1_Click()
    Dim i As Long, k As Long, r As Long
    Dim w As Long, sh As Worksheet
    Dim d As Object, arr(), arr2()
    Set d = CreateObject("scripting.dictionary")

    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            For i = 1 To sh.Range("iv1").End(xlToLeft).Column
                If Not d.exists(sh.Cells(1, i).Value) Then
                    s = s + 1
                    d(sh.Cells(1, i).Value) = s
                End If
            Next
        End If
    Next
    Sheets("汇总").[a1].Resize(1, s) = d.keys

    With UserForm1.ListView1
        For j = 1 To .ListItems.Count
            If .ListItems(j).Checked = True Then
                With Sheets(.ListItems(j).Text)
                    r = .Range("a65536").End(xlUp).Row
                    If r > 1 Then
                        ar = .Range("a1").Resize(r, s)
                        For i = 2 To UBound(ar)
                            k = k + 1
                            ReDim Preserve arr(1 To s, 1 To k)
                            For w = 1 To UBound(ar, 2)
                                If ar(1, w) <> "" Then arr(d(ar(1, w)), k) = ar(i, w)
                            Next
                        Next
                    End If
                End With
            End If
        Next
    End With
    If UserForm1.OptionButton1.Value = True Then
        With Sheets("汇总")
            .Cells.ClearContents
            If SafeArrayGetDim(arr) = 0 Then Exit Sub
            .Range("a1").Resize(1, s) = d.keys
            .Range("a2").Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)   '这一段是合并
        End With
    Else
        With Sheets("汇总")
            If SafeArrayGetDim(arr) = 0 Then Exit Sub
            .Cells.ClearContents
            .Range("a1").Resize(1, UBound(arr)) = d.keys
            d.RemoveAll
            k = 0
            For i = 1 To UBound(arr, 2)
                If Not d.exists(arr(1, i)) Then
                    k = k + 1
                    d(arr(1, i)) = k
                    ReDim Preserve arr2(1 To UBound(arr), 1 To k)
                    For w = 1 To UBound(arr)
                        arr2(w, d(arr(1, i))) = arr(w, i)
                    Next
                Else
                    For w = 2 To UBound(arr)
                     If arr(w, i) <> "" Then
                        arr2(w, d(arr(1, i))) = arr2(w, d(arr(1, i))) + arr(w, i)
                     End If
                    Next
                End If
            Next
            .Range("a2").Resize(UBound(arr2, 2), UBound(arr2)) = Application.Transpose(arr2)  '这一段是汇总
        End With
    End If
End Sub

qdchyq

mjzxlmg 发表于 2011-10-1 23:35
完整语句：
Private Sub CommandButton1_Click()
    Dim i As Long, k As Long, r As Long

谢谢！老师帮忙

luyina

不错！！！！！

LMY123

用字典把不等列多个工作表合并和汇总

jjmysjg

mjzxlmg 发表于 2011-10-1 23:35
完整语句：
Private Sub CommandButton1_Click()
    Dim i As Long, k As Long, r As Long

这个台强大了，大师怎么不来了