[已解决]编制折旧凭证问题

sunche

老师们，早！在写代码时遇到问题，请老师们看看！具体见附件。谢谢！

最佳答案

月排行榜 / 总排行榜

benhsu

2022-5-28 09:39

    Dim i, j As Double
    Set tp = CreateObject("Scripting.dictionary")
    ar = Sheet1.[C4:e6000]
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            tp(ar(i, 1)) = tp(ar(i, 1)) + ar(i, 3)
        End If
    Next i
    Sheet2.Range("B3").Resize(tp.Count, 2).Value = WorksheetFunction.Transpose(Array(tp.keys, tp.items))
    Call cal

跳转到最佳答案楼层

benhsu

    Dim i, j As Double
    Set tp = CreateObject("Scripting.dictionary")
    ar = Sheet1.[C4:e6000]
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            tp(ar(i, 1)) = tp(ar(i, 1)) + ar(i, 3)
        End If
    Next i
    Sheet2.Range("B3").Resize(tp.Count, 2).Value = WorksheetFunction.Transpose(Array(tp.keys, tp.items))
    Call cal

sunche

benhsu 发表于 2022-5-28 09:39
Dim i, j As Double
    Set tp = CreateObject("Scripting.dictionary")
    ar = Sheet1.[C4:e6000 ...

这个地方忽略了！谢谢老师！

sam-wang

Sub tt()
Dim Arr, xD, T$, n&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheet1.Range(Sheet1.[c3], Sheet1.[e65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 3)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 3)
Next
For Each ky In xD.keys
    n = n + 1: Brr(n, 1) = ky: Brr(n, 2) = xD(ky)
    Brr(xD.Count + 1, 3) = Brr(xD.Count + 1, 3) + Brr(n, 2)
Next
Brr(xD.Count + 1, 1) = "Total"
Sheet2.[b3].Resize(n + 1, 3) = Brr
End Sub

sunche

sam-wang 发表于 2022-5-28 11:40
Sub tt()
Dim Arr, xD, T$, n&
Set xD = CreateObject("Scripting.Dictionary")

谢谢老师，辛苦了！