[已解决]请搞手帮帮忙，把三个宏合并成一，谢谢了。

lbhlbh

请高手帮忙，下面三个代码是有规律的，只有四处不同（红色部分），能不能把把它们合并成一个？谢谢了！
Sub test1()
    Set d = CreateObject("scripting.dictionary")
    With Sheet5
        arr = .Range("a4:s" & .Cells(Rows.Count, 1).End(xlUp).Row)
        ReDim brr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr) - 1
            If arr(i, 3) = arr(i + 1, 3) Then
                n = n + 1
                d(arr(i, 3)) = n + 1
            Else
                n = 0
            End If
        Next
        For i = 1 To UBound(arr)
            If d.Exists(arr(i, 3)) Then
                brr(i, 1) = arr(i, 19) / d(arr(i, 3))
            Else
                brr(i, 1) = arr(i, 19)
            End If
           Next
        .[S4].Resize(UBound(brr), 1) = brr
    End With
End Sub
Sub test2()
    Set d = CreateObject("scripting.dictionary")
    With Sheet5
        arr = .Range("a4:q" & .Cells(Rows.Count, 1).End(xlUp).Row)
        ReDim brr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr) - 1
            If arr(i, 3) = arr(i + 1, 3) Then
                n = n + 1
                d(arr(i, 3)) = n + 1
            Else
                n = 0
            End If
        Next
        For i = 1 To UBound(arr)
            If d.Exists(arr(i, 3)) Then
                brr(i, 1) = arr(i, 17) / d(arr(i, 3))
            Else
                brr(i, 1) = arr(i, 17)
            End If
           Next
        .[Q4].Resize(UBound(brr), 1) = brr
    End With
End Sub
Sub test3()
    Set d = CreateObject("scripting.dictionary")
    With Sheet5
        arr = .Range("a4:r" & .Cells(Rows.Count, 1).End(xlUp).Row)
        ReDim brr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr) - 1
            If arr(i, 3) = arr(i + 1, 3) Then
                n = n + 1
                d(arr(i, 3)) = n + 1
            Else
                n = 0
            End If
        Next
        For i = 1 To UBound(arr)
            If d.Exists(arr(i, 3)) Then
                brr(i, 1) = arr(i, 18) / d(arr(i, 3))
            Else
                brr(i, 1) = arr(i, 18)
            End If
           Next
        .[r4].Resize(UBound(brr), 1) = brr
    End With
End Sub

最佳答案

月排行榜 / 总排行榜

橘子红

2015-4-5 00:07

没表,没法测试

1. Sub test1()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheet5
   
4.      For lastcol = 17 To 19
   
5.             arr = .Range(.Range("a4"), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, lastcol))
   
6.             ReDim brr(1 To UBound(arr), 1 To 1)
   
7.             For i = 1 To UBound(arr) - 1
   
8.                 If arr(i, 3) = arr(i + 1, 3) Then
   
9.                     n = n + 1
   
10.                     d(arr(i, 3)) = n + 1
    
11.                 Else
    
12.                     n = 0
    
13.                 End If
    
14.             Next
    
15.             For i = 1 To UBound(arr)
    
16.                 If d.Exists(arr(i, 3)) Then
    
17.                     brr(i, 1) = arr(i, lastcol) / d(arr(i, 3))
    
18.                 Else
    
19.                     brr(i, 1) = arr(i, lastcol)
    
20.                 End If
    
21.                Next
    
22.             .Cells(4, lastcol).Resize(UBound(brr), 1) = brr
    
23.         Next
    
24.     End With
    
25. End Sub

复制代码

跳转到最佳答案楼层

橘子红

没表,没法测试

1. Sub test1()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheet5
   
4.      For lastcol = 17 To 19
   
5.             arr = .Range(.Range("a4"), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, lastcol))
   
6.             ReDim brr(1 To UBound(arr), 1 To 1)
   
7.             For i = 1 To UBound(arr) - 1
   
8.                 If arr(i, 3) = arr(i + 1, 3) Then
   
9.                     n = n + 1
   
10.                     d(arr(i, 3)) = n + 1
    
11.                 Else
    
12.                     n = 0
    
13.                 End If
    
14.             Next
    
15.             For i = 1 To UBound(arr)
    
16.                 If d.Exists(arr(i, 3)) Then
    
17.                     brr(i, 1) = arr(i, lastcol) / d(arr(i, 3))
    
18.                 Else
    
19.                     brr(i, 1) = arr(i, lastcol)
    
20.                 End If
    
21.                Next
    
22.             .Cells(4, lastcol).Resize(UBound(brr), 1) = brr
    
23.         Next
    
24.     End With
    
25. End Sub

复制代码

lbhlbh

橘子红 发表于 2015-4-5 00:07
没表,没法测试

可以了，非常谢谢