gpt4 book ai didi

arrays - 在VBA中返回数组的函数

转载 作者:行者123 更新时间:2023-12-04 19:47:31 25 4
gpt4 key购买 nike

我是一名会计师,我需要每天将每个客户的付款与未结发票进行匹配,我在这个网站上找到了 Michael Schwimmer 发布的一个非常漂亮和优雅的 VBA 代码。 https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem

代码运行完美,它可以自动计算并列出相加到特定总和的结果。但是,我希望 VBA 代码也返回发票号。代码将值数组传递给函数进行计算,然后将可能的解决方案返回到列 E,我不了解数组,所以不知道如何将发票编号数组传递给函数并返回结果。有人能帮忙吗?代码如下,也可以到link下载excel工作簿我提供了。提前致谢!

enter image description here enter image description here

Private Sub cmbCalculate_Click()

Dim dGoal As Double
Dim dTolerance As Double
Dim dAmounts() As Double
Dim vResult As Variant
Dim m As Long
Dim n As Long

With Me

dGoal = .Range("B2")
dTolerance = .Range("C2")
ReDim dAmounts(1 To 100)
For m = 2 To 101
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
dAmounts(m - 1) = .Cells(m, 1)
Else
ReDim Preserve dAmounts(1 To m - 1)
Exit For
End If
Next
ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)

vResult = Combinations(dAmounts, dGoal, dTolerance)
Application.ScreenUpdating = False
.Range("D3:D65536").ClearContents
.Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
Application.ScreenUpdating = True

End With

End Sub

Function Combinations( _
Elements As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant

Dim i As Long
Dim k As Long
Dim dCompare As Double
Dim dDummy As Double
Dim vDummy As Variant
Dim vResult As Variant

If Not IsMissing(SoFar) Then

'Sum of elements so far
For Each vDummy In SoFar
dCompare = dCompare + vDummy
Next

Else

'Start elements sorted by amount
For i = 1 To UBound(Elements)
For k = i + 1 To UBound(Elements)
If Elements(k) < Elements(i) Then
dDummy = Elements(i)
Elements(i) = Elements(k)
Elements(k) = dDummy
End If
Next
Next

Set SoFar = New Collection

End If

If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)

'Add current element
SoFar.Add Elements(i)
dCompare = dCompare + Elements(i)

If Abs(Goal - dCompare) < (0.001 + Tolerance) Then

'Goal achieved
k = 0
ReDim vResult(0 To SoFar.Count - 1, 0)
For Each vDummy In SoFar
vResult(k, 0) = vDummy
k = k + 1
Next
Combinations = vResult
Exit For

ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations(Elements, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If

Else

'Amount too high
SoFar.Remove SoFar.Count
Exit For

End If

Next 'Try next higher amount

End Function

最佳答案

您可能只需使用 VLOOKUP 即可获得发票编号,但这里是一个 VBA 解决方案。我已将 Sofar 集合中的值从发票金额更改为该金额的索引号。该索引号然后从新数组 InvNo 中给出相应的发票号。

更新 - 按截止日期排序

Sub cmbCalculate_Click()

Dim ws As Worksheet, dAmounts() As Double, sInvno() As String
Dim i As Long, dSum As Double
Dim dtDue() As Date

Set ws = Me
i = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim dAmounts(1 To i - 1)
ReDim sInvno(1 To i - 1)
ReDim dtDue(1 To i - 1)

' fill array
For i = 1 To UBound(dAmounts)
dAmounts(i) = ws.Cells(i + 1, "A")
sInvno(i) = ws.Cells(i + 1, "B")
dtDue(i) = ws.Cells(i + 1, "C")
dSum = dSum + dAmounts(i)
Next
' sort array
Call BubbleSort(dAmounts, sInvno, dtDue)
Dim n: For n = LBound(dAmounts) To UBound(dAmounts): Debug.Print n, dAmounts(n), sInvno(n), dtDue(n): Next

Dim dGoal As Double, dTolerance As Double, vResult As Variant
dGoal = ws.Range("D2")
dTolerance = ws.Range("E2")

' check possible
If dGoal > dSum Then
MsgBox "Error : Total for Invoices " & Format(dSum, "#,##0.00") & _
" is less than Goal " & Format(dGoal, "#,##0.00")
Else
' solve and write to sheet
vResult = Combinations2(dAmounts, sInvno, dtDue, dGoal, dTolerance)
If IsArray(vResult) Then
With ws
.Range("F3:H" & Rows.Count).ClearContents
.Range("F3").Resize(UBound(vResult), 3) = vResult
End With
MsgBox "Done"
Else
MsgBox "Cannot find suitable combination", vbCritical
End If
End If

End Sub


Function Combinations2( _
Elements As Variant, _
Invno As Variant, _
Due As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant

Dim i As Long, n As Long, dCompare As Double

' summate so far
If IsMissing(SoFar) Then
Set SoFar = New Collection
Else
For i = 1 To SoFar.Count
dCompare = dCompare + Elements(SoFar(i))
Next
End If

If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)

SoFar.Add CStr(i)
dCompare = dCompare + Elements(i)

' check if target achieved
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then

'Goal achieved
Dim vResult As Variant
ReDim vResult(1 To SoFar.Count, 1 To 3)
For n = 1 To SoFar.Count
vResult(n, 1) = Elements(SoFar(n))
vResult(n, 2) = Invno(SoFar(n))
vResult(n, 3) = Due(SoFar(n))
Next
Combinations2 = vResult

ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations2(Elements, Invno, Due, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations2 = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If
Else

'Amount too high
SoFar.Remove SoFar.Count
Exit For
End If
Next
End Function

Sub BubbleSort(ByRef ar1 As Variant, ByRef ar2 As Variant, ByRef ar3 As Variant)
' sort both arrays
Dim d, s, i As Long, k As Long, dt As Date
For i = 1 To UBound(ar1)
For k = i + 1 To UBound(ar1)
If (ar1(k) < ar1(i)) Or _
(ar1(k) = ar1(i) _
And ar3(k) < ar3(i)) Then
d = ar1(i)
ar1(i) = ar1(k)
ar1(k) = d
s = ar2(i)
ar2(i) = ar2(k)
ar2(k) = s
dt = ar3(i)
ar3(i) = ar3(k)
ar3(k) = dt
End If
Next
Next
End Sub

关于arrays - 在VBA中返回数组的函数,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/68364052/

25 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com