[已解决]请高手修改代码，在线等，急。。。。

过江龙

附件是我在论坛上下载的，代码稍有改动，请问，怎样修改才能实现我的如下要求呢？

当汇总表中已有分表中的姓名时就重新更新，否则就将各分表的内容写入汇总表中。不知表述清楚没有，谢谢！

 

Zv5oS13D.rar (24.66 KB, 下载次数: 1)

2010-6-4 08:15 上传

点击文件名下载附件
请高手修改代码，在线等，急。。。。

最佳答案

月排行榜 / 总排行榜

amulee

2010-6-4 09:05

Sub 汇总工作表()
    Dim d
    Dim Arr, ArrJG, i&, j&, PathName$, dirna, K, Temp
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    '先处理本表
    column1 = Range("IV1").End(xlToLeft).Column
    Arr = Range(Range("a2"), Cells(Range("A65536").End(xlUp).Row, column1))
    K = 0
    ReDim ArrJG(1 To column1, 1 To 1)
    For i = 1 To UBound(Arr)
        If Not d.exists(Arr(i, 1)) Then
            K = K + 1
            ReDim Preserve ArrJG(1 To column1, 1 To K)
            d(Arr(i, 1)) = K
        End If
        Temp = d(Arr(i, 1))
        For j = 1 To column1
            ArrJG(j, Temp) = Arr(i, j)
        Next j
    Next i
    PathName = ThisWorkbook.Path & "\*.xls"
    dirna = Dir(PathName)
    Do While dirna <> ""
        If dirna <> "汇总表.xls" Then
            Set App = Application
            Set SourceBook = App.Workbooks.Open(ThisWorkbook.Path & "\" & dirna, 0, True)
            Set Sourcesheet = SourceBook.Worksheets("Sheet1")
            With Sourcesheet
                Arr = .Range(.Range("a2"), .Cells(.Range("A65536").End(xlUp).Row, column1))
            End With
            SourceBook.Close False
            For i = 1 To UBound(Arr)
                If Not d.exists(Arr(i, 1)) Then
                    K = K + 1
                    ReDim Preserve ArrJG(1 To column1, 1 To K)
                    d(Arr(i, 1)) = K
                End If
                Temp = d(Arr(i, 1))
                For j = 1 To column1
                    ArrJG(j, Temp) = Arr(i, j)
                Next j
            Next i
            Erase Arr
            End If
        dirna = Dir
    Loop
    Range(Range("A2"), Cells(65536, column1)).ClearContents
    Range("A2").Resize(UBound(ArrJG, 2), column1) = Application.Transpose(ArrJG)
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

开辆小富康

直接擦除了重写嘛。那样反而简便。

搁浅2008

按工作表的摆放顺序 后边的更新前边的么 名字有重复么 要是没有 就字典+数组方便些

过江龙

是的，姓名没有重复，谢谢！

amulee

Sub 汇总工作表()
    Dim d
    Dim Arr, ArrJG, i&, j&, PathName$, dirna, K, Temp
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    '先处理本表
    column1 = Range("IV1").End(xlToLeft).Column
    Arr = Range(Range("a2"), Cells(Range("A65536").End(xlUp).Row, column1))
    K = 0
    ReDim ArrJG(1 To column1, 1 To 1)
    For i = 1 To UBound(Arr)
        If Not d.exists(Arr(i, 1)) Then
            K = K + 1
            ReDim Preserve ArrJG(1 To column1, 1 To K)
            d(Arr(i, 1)) = K
        End If
        Temp = d(Arr(i, 1))
        For j = 1 To column1
            ArrJG(j, Temp) = Arr(i, j)
        Next j
    Next i
    PathName = ThisWorkbook.Path & "\*.xls"
    dirna = Dir(PathName)
    Do While dirna <> ""
        If dirna <> "汇总表.xls" Then
            Set App = Application
            Set SourceBook = App.Workbooks.Open(ThisWorkbook.Path & "\" & dirna, 0, True)
            Set Sourcesheet = SourceBook.Worksheets("Sheet1")
            With Sourcesheet
                Arr = .Range(.Range("a2"), .Cells(.Range("A65536").End(xlUp).Row, column1))
            End With
            SourceBook.Close False
            For i = 1 To UBound(Arr)
                If Not d.exists(Arr(i, 1)) Then
                    K = K + 1
                    ReDim Preserve ArrJG(1 To column1, 1 To K)
                    d(Arr(i, 1)) = K
                End If
                Temp = d(Arr(i, 1))
                For j = 1 To column1
                    ArrJG(j, Temp) = Arr(i, j)
                Next j
            Next i
            Erase Arr
            End If
        dirna = Dir
    Loop
    Range(Range("A2"), Cells(65536, column1)).ClearContents
    Range("A2").Resize(UBound(ArrJG, 2), column1) = Application.Transpose(ArrJG)
    Application.ScreenUpdating = True
End Sub

BAIXINGR

学习下

过江龙

谢谢老师！