对号入座问题

小星光

请教老师们对号入座问题

蓝桥玄霜

没有收款日期？

3190496160

Sub 分配()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("登记表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    br = .Range("a1:f" & rs)
End With
With Sheets("明细表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 3), .Cells(r, y)) = Empty
    ar = .Range(.Cells(1, 1), .Cells(r, y))
    For j = 3 To UBound(ar, 2)
        If Trim(ar(1, j)) <> "" Then
            zd = Format(ar(1, j), "yyyy/m")
            d(zd) = j
        End If
    Next j
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            d(Trim(ar(i, 2))) = i
        End If
    Next i
    For i = 2 To UBound(br)
        If Trim(br(i, 2)) <> "" And Trim(br(i, 3)) <> "" Then
            If IsDate(br(i, 2)) And IsDate(br(i, 3)) Then
                ys = DateDiff("m", br(i, 2), br(i, 3)) + 1
                xh = d(Trim(br(i, 1)))
                zd = Format(br(i, 2), "yyyy/m")
                zf = Format(br(i, 3), "yyyy/m")
                ks = d(zd)
                js = d(zf)
                If xh <> "" And ks <> "" And js <> "" Then
                    ar(xh, 3) = br(i, 4)
                    For j = ks To js
                        ar(xh, j) = br(i, 4) / ys
                    Next j
                End If
            End If
        End If
    Next i
    .Range(.Cells(1, 1), .Cells(r, y)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

登记表.rar (22.51 KB, 下载次数: 16)

2023-4-16 09:44 上传

点击文件名下载附件

小星光

3190496160 发表于 2023-4-16 09:44

3190496160大师您好：分配成功，谢谢您！

清风竹-

参与一下。

小星光

清风竹- 发表于 2023-4-16 10:38
参与一下。

谢谢您们各位大师：您们写的代码都很棒！谢谢您们！

全党

参与一下。。。。。。。。。。。

熊文来

全党 发表于 2023-4-17 06:17
参与一下。。。。。。。。。。。

简洁的优秀作品。