[已解决]dsmch老师，还有疑问？？？

新一

[已解决]dsmch老师，有空帮我看看，谢谢。
http://www.excelpx.com/thread-323493-1-1.html
当表三为空白时，明细表E列不能求和？？

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-8 20:47

Sub Macro1()
On Error Resume Next
Dim arr, brr, crr(1 To 16, 1 To 8), d
Dim n&, k%, j&, i&, s&, ar, br, cr
Set d = CreateObject("scripting.dictionary")
br = Sheets("装模").Range("a1").CurrentRegion
cr = Sheets("明细表").Range("b5:b" & Sheets("明细表").Range("b65536").End(xlUp).Row)
Range("a3:h65536").ClearContents
n = 3
For k = 1 To 2
    arr = Sheets(k).UsedRange
    For i = 2 To UBound(arr)
        If InStr(arr(i, 1), "对应单号") And Len(arr(i, 1)) > 5 Then
            brr = Sheets(k).Cells(i, 1).Resize(16, 8)
            y = Val(brr(1, 6)): m = Val(brr(1, 7)): r = Val(brr(1, 8))
            rq = DateSerial(y, m, r)
            dh = Mid(brr(1, 1), 6)
            mc = Mid(brr(2, 1), 4)
            s = 0
            For j = 4 To UBound(brr)
                If brr(j, 2) <> "" Then
                    s = s + 1
                    crr(s, 1) = rq
                    crr(s, 2) = dh
                    crr(s, 3) = mc
                    crr(s, 4) = brr(j, 2)
                    crr(s, 5) = brr(j, 5)
                    crr(s, 6) = brr(j, 6)
                    crr(s, 7) = brr(j, 7)
                    crr(s, 8) = brr(j, 3)
                End If
            Next
            Cells(n, 1).Resize(s, UBound(crr, 2)) = crr
            n = n + s
        End If
    Next
Next
x = Sheet3.Range("a65536").End(xlUp).Row + 1
'If x < 3 Then Exit Sub删除该行
Sheet3.Range("a3:h" & x).Copy Cells(n, 1)
ar = Range("a1").CurrentRegion
For i = 3 To UBound(ar)
    d(ar(i, 8)) = d(ar(i, 8)) + ar(i, 7)
Next
For i = 2 To UBound(br)
    d(br(i, 8)) = d(br(i, 8)) + br(i, 7)
Next
For i = 1 To UBound(cr)
    cr(i, 1) = d(cr(i, 1))
Next
Sheets("明细表").Range("e5").Resize(UBound(cr)) = cr
End Sub

跳转到最佳答案楼层

dsmch

Sub Macro1()
On Error Resume Next
Dim arr, brr, crr(1 To 16, 1 To 8), d
Dim n&, k%, j&, i&, s&, ar, br, cr
Set d = CreateObject("scripting.dictionary")
br = Sheets("装模").Range("a1").CurrentRegion
cr = Sheets("明细表").Range("b5:b" & Sheets("明细表").Range("b65536").End(xlUp).Row)
Range("a3:h65536").ClearContents
n = 3
For k = 1 To 2
    arr = Sheets(k).UsedRange
    For i = 2 To UBound(arr)
        If InStr(arr(i, 1), "对应单号") And Len(arr(i, 1)) > 5 Then
            brr = Sheets(k).Cells(i, 1).Resize(16, 8)
            y = Val(brr(1, 6)): m = Val(brr(1, 7)): r = Val(brr(1, 8))
            rq = DateSerial(y, m, r)
            dh = Mid(brr(1, 1), 6)
            mc = Mid(brr(2, 1), 4)
            s = 0
            For j = 4 To UBound(brr)
                If brr(j, 2) <> "" Then
                    s = s + 1
                    crr(s, 1) = rq
                    crr(s, 2) = dh
                    crr(s, 3) = mc
                    crr(s, 4) = brr(j, 2)
                    crr(s, 5) = brr(j, 5)
                    crr(s, 6) = brr(j, 6)
                    crr(s, 7) = brr(j, 7)
                    crr(s, 8) = brr(j, 3)
                End If
            Next
            Cells(n, 1).Resize(s, UBound(crr, 2)) = crr
            n = n + s
        End If
    Next
Next
x = Sheet3.Range("a65536").End(xlUp).Row + 1
'If x < 3 Then Exit Sub删除该行
Sheet3.Range("a3:h" & x).Copy Cells(n, 1)
ar = Range("a1").CurrentRegion
For i = 3 To UBound(ar)
    d(ar(i, 8)) = d(ar(i, 8)) + ar(i, 7)
Next
For i = 2 To UBound(br)
    d(br(i, 8)) = d(br(i, 8)) + br(i, 7)
Next
For i = 1 To UBound(cr)
    cr(i, 1) = d(cr(i, 1))
Next
Sheets("明细表").Range("e5").Resize(UBound(cr)) = cr
End Sub

新一

谢谢老师{:011:}