应缴款和实缴款的分次匹配

liuming168

用VBA代码匹配成如下表
网上找了一个模板

Sub OptimizedAllocateSupplies()
    Dim wsDemand As Worksheet, wsSupply As Worksheet
    Set wsDemand = ThisWorkbook.Worksheets("需求")
    Set wsSupply = ThisWorkbook.Worksheets("供应")
   
    ' 读取供应数据（增强数据验证）
    Dim lastSupplyRow As Long
    lastSupplyRow = wsSupply.Cells(wsSupply.Rows.Count, "A").End(xlUp).Row
    If lastSupplyRow < 2 Then
        MsgBox "供应表没有数据！", vbExclamation
        Exit Sub
    End If
   
    ' 存储批次和剩余数量（使用更清晰的变量名）
    Dim supplyData() As Variant, supplyCount As Long
    supplyCount = lastSupplyRow - 1
    ReDim supplyData(1 To supplyCount, 1 To 2)
   
    For i = 2 To lastSupplyRow
        If Not IsNumeric(wsSupply.Cells(i, "B").Value) Or wsSupply.Cells(i, "B").Value < 0 Then
            MsgBox "供应表第 " & i & " 行数据无效！", vbCritical
            Exit Sub
        End If
        supplyData(i - 1, 1) = wsSupply.Cells(i, "A").Value   ' 批次名称
        supplyData(i - 1, 2) = CLng(wsSupply.Cells(i, "B").Value) ' 商品数量
    Next i
   
    ' 读取需求数据到数组提升性能
    Dim lastDemandRow As Long
    lastDemandRow = wsDemand.Cells(wsDemand.Rows.Count, "A").End(xlUp).Row
    If lastDemandRow < 2 Then
        MsgBox "需求表没有数据！", vbExclamation
        Exit Sub
    End If
   
    ' 清空旧数据（精确控制范围）
    With wsDemand
        If .UsedRange.Columns.Count >= 3 Then
            .Range(.Cells(2, 3), .Cells(lastDemandRow, .UsedRange.Columns.Count)).ClearContents
        End If
    End With
   
    ' 使用数组处理需求数据
    Dim demandData As Variant
    demandData = wsDemand.Range("A2:B" & lastDemandRow).Value
   
    ' 主分配逻辑
    For i = 1 To UBound(demandData, 1)
        Dim customerName As String
        Dim remainingDemand As Long
        Dim allocationRecords As Collection
        Set allocationRecords = New Collection
        
        customerName = CStr(demandData(i, 1))
        If Not IsNumeric(demandData(i, 2)) Then
            wsDemand.Cells(i + 1, 3).Value = "无效需求"
            GoTo NextCustomer
        End If
        remainingDemand = CLng(demandData(i, 2))
        If remainingDemand <= 0 Then GoTo NextCustomer
        
        ' 分配批次
        For s = 1 To supplyCount
            If supplyData(s, 2) > 0 Then
                Dim allocateQty As Long
                allocateQty = Application.Min(remainingDemand, supplyData(s, 2))
               
                ' 记录分配信息
                allocationRecords.Add Array(supplyData(s, 1), allocateQty)
               
                ' 更新库存和需求
                supplyData(s, 2) = supplyData(s, 2) - allocateQty
                remainingDemand = remainingDemand - allocateQty
               
                If remainingDemand = 0 Then Exit For
            End If
        Next s
        
        ' 写入分配结果（批量写入提升性能）
        If allocationRecords.Count > 0 Then
            Dim outputArray() As Variant
            ReDim outputArray(1 To allocationRecords.Count * 2)
            
            For n = 1 To allocationRecords.Count
                outputArray((n - 1) * 2 + 1) = allocationRecords(n)(0)
                outputArray((n - 1) * 2 + 2) = allocationRecords(n)(1)
            Next n
            
            wsDemand.Cells(i + 1, 3).Resize(1, UBound(outputArray)).Value = outputArray
        End If
        
        ' 处理剩余需求
        If remainingDemand > 0 Then
            wsDemand.Cells(i + 1, 3 + allocationRecords.Count * 2).Value = "不足: " & remainingDemand
        End If
        
NextCustomer:
    Next i
   
    ' 更新供应表状态（可选）
    ' For s = 1 To supplyCount
    '     wsSupply.Cells(s + 1, 2).Value = supplyData(s, 2)
    ' Next s
   
    MsgBox "分配完成！", vbInformation
End Sub
基本解决问题了如附件“供应与需求匹配法”。

3190496160

两个表根据什么匹配？？

一招秒杀

1句13行，一眼看尽，专业工具，优雅结果，简单真美

翁知江安

Sub test250413()
Dim i, j, k, m, n As Integer, ar, br, cr As Variant
With Sheets("应缴款")
ar = .Range("a1:c" & .[a1].End(xlDown).Row)
cr = .[d1].Resize(UBound(ar), 100)
End With
br = Sheets("缴款明细").[a1].CurrentRegion
m = 2: n = 2: j = 1
For i = 1 To 1000
   If ar(m, 3) > br(n, 3) Then
     cr(m, 3 * j - 2) = br(n, 2): cr(m, 3 * j - 1) = br(n, 3): cr(m, 3 * j) = DateDiff("d", ar(m, 2), br(n, 2))
      ar(m, 3) = ar(m, 3) - br(n, 3): n = n + 1: j = j + 1
    Else
       If ar(m, 3) = br(n, 3) Then
        cr(m, 3 * j - 2) = br(n, 2): cr(m, 3 * j - 1) = br(n, 3): cr(m, 3 * j) = DateDiff("d", ar(m, 2), br(n, 2))
         m = m + 1: n = n + 1: j = 1
       Else
         cr(m, 3 * j - 2) = br(n, 2): cr(m, 3 * j - 1) = ar(m, 3): cr(m, 3 * j) = DateDiff("d", ar(m, 2), br(n, 2))
         br(n, 3) = br(n, 3) - ar(m, 3): m = m + 1: j = 1
         End If
    End If
    If m > UBound(ar) Or n > UBound(br) Then
      Exit For
    End If
Next
Sheets("应缴款").[d1].Resize(UBound(ar), 50).ClearContents
Sheets("应缴款").[d1].Resize(UBound(ar), 50) = cr
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

liuming168

代码简捷明了，高手！！

sunya_0529

WPS里的JSA练习一下——

rendiule01

一招秒杀 发表于 2025-4-12 21:44
1句13行，一眼看尽，专业工具，优雅结果，简单真美

云服务器  安装了微信和python, 有代码生成csv文件
只要微信有新信息，更新csv文件，然后本地excel读取csv文件的数据，这个怎么做？

一招秒杀

  手机上看到软件有新版本的消息，升级后突然发现原来还多定义了1个没用到的Window, 去除后顺手再把天数补上 。