请教各位老师关于根据工号搜索数据并叠加数据的代码，不如进来一坐小女谢谢大家

wangluoren

不好意思请教各位老师关于根据工号搜索数据并叠加数据的代码，不如进来一坐小女谢谢大家..真的是不好意思了，请用最简单的代码编写，不然本小姐看不懂耶  请看图或附件      下面几个老师的我都没看懂，小女子初学，希望老师们给最简单的代码谢谢大家了

liulang0808

Sub 按钮1_单击()
    Application.ScreenUpdating = False
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Set d3 = CreateObject("scripting.dictionary")
    Set d4 = CreateObject("scripting.dictionary")
    arr = ActiveSheet.UsedRange
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            d1(arr(j, 1)) = arr(j, 2)
            d2(arr(j, 1)) = arr(j, 3) + d2(arr(j, 1))
            d3(arr(j, 1)) = arr(j, 4) + d3(arr(j, 1))
            d4(arr(j, 1)) = arr(j, 5) + d4(arr(j, 1))
            
        End If
    Next j
    For j = 2 To UBound(arr)
        If Len(arr(j, 9)) > 0 Then
            arr(j, 10) = d1(arr(j, 9))
            arr(j, 11) = d2(arr(j, 9))
            arr(j, 12) = d3(arr(j, 9))
            arr(j, 13) = d4(arr(j, 9))
            
        End If
    Next j
     ActiveSheet.UsedRange = arr
    Application.ScreenUpdating = True
End Sub

liulang0808

看看是否满足需求吧

liulang0808

见此附件，之前附件有问题的，没有代码

excel002009

1. Sub 搜索叠加()
   
2. Dim d As Object, arr, i%, j%, sr$, s, brr(1 To 5000, 1 To 5), a, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a4:e" & Range("a" & Rows.Count).End(xlUp).Row)
   
5. Range("i5:m10000").ClearContents
   
6. For i = 2 To UBound(arr)
   
7.     d(arr(i, 1) & "," & arr(i, 2)) = d(arr(i, 1) & "," & arr(i, 2)) & "," & i
   
8. Next
   
9. For Each a In d.keys
   
10.     k = k + 1
    
11.     brr(k, 1) = Split(a, ",")(0): brr(k, 2) = Split(a, ",")(1)
    
12.     sr = d(a)
    
13.     s = Split(sr, ",")
    
14.     For i = 1 To UBound(s)
    
15.         brr(k, 3) = brr(k, 3) + arr(s(i), 3)
    
16.         brr(k, 4) = brr(k, 4) + arr(s(i), 4)
    
17.         brr(k, 5) = brr(k, 5) + arr(s(i), 5)
    
18.     Next
    
19. Next
    
20. Range("i5").Resize(k, 5) = brr
    
21. End Sub
    

复制代码

excel002009

你那含解释的合并单元格与I：M列有交集，把那合并单元格取消合并吧。
数据搜索.zip (10.84 KB, 下载次数: 4)

2014-11-23 18:30 上传

点击文件名下载附件

yaozong

1. Sub yy()
   
2. Dim d, arr, s$, i&, j&, m&, x&, y&
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = [a4].CurrentRegion
   
5. x = UBound(arr, 2)
   
6. y = UBound(arr)
   
7. ReDim brr(1 To y, 1 To x)
   
8. For i = 2 To y
   
9.    s = arr(i, 1) & arr(i, 2)
   
10.    If Not d.exists(s) Then
    
11.       m = m + 1
    
12.       d(s) = m
    
13.       brr(m, 1) = arr(i, 1)
    
14.       brr(m, 2) = arr(i, 2)
    
15.       For j = 3 To x
    
16.          If arr(i, j) <> Empty Then brr(m, j) = arr(i, j)
    
17.       Next
    
18.    Else
    
19.       For j = 3 To x
    
20.          If arr(i, j) <> Empty Then brr(d(s), j) = brr(d(s), j) + arr(i, j)
    
21.       Next
    
22.    End If
    
23. Next
    
24. [i5].CurrentRegion.Offset(1).Clear
    
25. [i5].Resize(m, x) = brr
    
26. [i5].CurrentRegion.Borders.LineStyle = 1
    
27. Set d = Nothing
    
28. End Sub

复制代码

yaozong

测试附件                 

zax010

Sub zz()
    Dim d, arr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("A4").CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = Application.Index(arr, i)
        Else
            s = d(arr(i, 1))
            For j = 3 To UBound(s)
                s(j) = s(j) + arr(i, j)
            Next
            d(arr(i, 1)) = s
        End If
    Next
    For i = 5 To [i65536].End(3).Row
        Cells(i, "i").Resize(1, 5) = d(Cells(i, "i").Value)
    Next
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>>
数据搜索.rar (8.56 KB, 下载次数: 16)

2014-11-23 19:24 上传

点击文件名下载附件