Option Explicit
'v4
Sub Заполнить_отправителей()
Application.StatusBar = "Ждите..."
Dim shBeru As Worksheet
Set shBeru = Sheets("Берут")
Dim shOtda As Worksheet
Set shOtda = Sheets("Отдают")
Dim dicOtda As Dictionary
Set dicOtda = GetDicOtda(shOtda, xGrp:=1, xToo:=5, xQua:=11)
Dim rTarget As Range
Set rTarget = shBeru.Cells(1, 10)
rTarget.Resize(shBeru.UsedRange.Rows.Count, shBeru.UsedRange.Columns.Count).Clear
Dim aPered As Variant
aPered = GetPeredArray(dicOtda:=dicOtda, shOtda:=shOtda, xOtdaTtt:=3, xOtdaTch:=4, xOtdaToo:=5, xOtdaQua:=11, shBeru:=shBeru, xBeruGrp:=1, xBeruToo:=5, xBeruQua:=8, rTarget:=rTarget)
If IsEmpty(aPered) Then
Application.StatusBar = False
Exit Sub
End If
PrintArray rTarget, aPered
Application.StatusBar = False
End Sub
Private Sub PrintArray(rTarget As Range, arr As Variant)
rTarget.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Private Function GetPeredArray(dicOtda As Dictionary, shOtda As Worksheet, xOtdaTtt As Long, xOtdaTch As Long, xOtdaToo As Long, xOtdaQua As Long, shBeru As Worksheet, xBeruGrp As Long, xBeruToo As Long, xBeruQua As Long, rTarget As Range) As Variant
Dim aOtdaTt As Variant, aOtdaTo As Variant, aOtdaTc As Variant, aOtdaQu As Variant
With shOtda
aOtdaTt = .Cells(1, xOtdaTtt).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
aOtdaTo = .Cells(1, xOtdaTch).Resize(UBound(aOtdaTt, 1), 1).Value
aOtdaTc = .Cells(1, xOtdaToo).Resize(UBound(aOtdaTt, 1), 1).Value
aOtdaQu = .Cells(1, xOtdaQua).Resize(UBound(aOtdaTt, 1), 1).Value
End With
Dim aBeruGr As Variant, aBeruTo As Variant, aBeruQu As Variant
With shBeru
aBeruGr = .Cells(1, xBeruGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
aBeruTo = .Cells(1, xBeruToo).Resize(UBound(aBeruGr, 1), 1).Value
aBeruQu = .Cells(1, xBeruQua).Resize(UBound(aBeruGr, 1), 1).Value
End With
Dim aPered As Variant
ReDim aPered(1 To UBound(aBeruGr, 1))
Dim sTO As String, allTO As Variant
Dim yb As Long, aOtdaY As Variant, yOtda As Variant, yOpt As Long, dd As Double
For Each allTO In Array(False, True)
For yb = 1 To UBound(aBeruGr, 1)
If IsNumeric(aBeruQu(yb, 1)) Then
If aBeruQu(yb, 1) > 0 Then
If allTO Then
sTO = "All"
Else
sTO = aBeruTo(yb, 1)
End If
If dicOtda.Exists(sTO) Then
If dicOtda(sTO).Exists(aBeruGr(yb, 1)) Then
aOtdaY = dicOtda(sTO)(aBeruGr(yb, 1)).Keys()
Do
If aBeruQu(yb, 1) <= 0 Then Exit Do
yOpt = 0
For Each yOtda In aOtdaY
If aOtdaQu(yOtda, 1) > 0 Then
If yOpt = 0 Then
yOpt = yOtda
ElseIf aOtdaQu(yOtda, 1) = aBeruQu(yb, 1) Then
yOpt = yOtda
Exit For
Else
If Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) < Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
yOpt = yOtda
ElseIf Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) = Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
If aOtdaQu(yOtda, 1) > aOtdaQu(yOpt, 1) Then
yOpt = yOtda
End If
End If
End If
End If
Next
If yOpt = 0 Then Exit Do
dd = aBeruQu(yb, 1)
If dd > aOtdaQu(yOpt, 1) Then dd = aOtdaQu(yOpt, 1)
aBeruQu(yb, 1) = aBeruQu(yb, 1) - dd
aOtdaQu(yOpt, 1) = aOtdaQu(yOpt, 1) - dd
If IsEmpty(aPered(yb)) Then
ReDim aTmp(1 To 1)
Else
aTmp = aPered(yb)
ReDim Preserve aTmp(LBound(aTmp) To UBound(aTmp) + 1)
End If
aTmp(UBound(aTmp)) = Array(yOpt, dd)
aPered(yb) = aTmp
DoEvents
Loop
End If
End If
End If
End If
Next
Next
Dim xPered As Long
For yb = 1 To UBound(aPered)
If Not IsEmpty(aPered(yb)) Then
aTmp = aPered(yb)
If xPered < UBound(aTmp) Then
xPered = UBound(aTmp)
End If
End If
Next
If xPered = 0 Then Exit Function
Const N_COL = 4
Dim bPered As Variant, xp As Long
ReDim bPered(1 To UBound(aPered), 1 To N_COL * xPered)
For xp = 1 To xPered
bPered(2, N_COL * (xp - 1) + 1) = "К перемещению"
bPered(2, N_COL * (xp - 1) + 2) = "Код ТТ"
bPered(2, N_COL * (xp - 1) + 3) = "Точка отправитель"
bPered(2, N_COL * (xp - 1) + 4) = "ТО"
Next
For yb = 1 To UBound(aPered)
If Not IsEmpty(aPered(yb)) Then
aTmp = aPered(yb)
xPered = 0
For xp = LBound(aTmp) To UBound(aTmp)
yOtda = aTmp(xp)(0)
bPered(yb, xPered + 1) = aTmp(xp)(1)
bPered(yb, xPered + 2) = aOtdaTt(yOtda, 1)
bPered(yb, xPered + 3) = aOtdaTo(yOtda, 1)
bPered(yb, xPered + 4) = aOtdaTc(yOtda, 1)
rTarget.Columns(xPered + 1).Resize(UBound(aPered)).Interior.Color = RGB(189, 215, 238)
xPered = xPered + N_COL
Next
End If
Next
GetPeredArray = bPered
End Function
Private Function GetDicOtda(sh As Worksheet, xGrp As Long, xToo As Long, xQua As Long) As Dictionary
Dim agr As Variant, ato As Variant, aqu As Variant
With sh
agr = .Cells(1, xGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
ato = .Cells(1, xToo).Resize(UBound(agr, 1), 1).Value
aqu = .Cells(1, xQua).Resize(UBound(agr, 1), 1).Value
End With
Dim dic As New Dictionary
Dim yg As Long, vTO As Variant
For yg = 1 To UBound(agr, 1)
If Not IsEmpty(agr(yg, 1)) Then
If IsNumeric(aqu(yg, 1)) Then
If aqu(yg, 1) > 0 Then
For Each vTO In Array("All", ato(yg, 1))
If Not dic.Exists(vTO) Then
Set dic(vTO) = New Dictionary
End If
If Not dic(vTO).Exists(agr(yg, 1)) Then
Set dic(vTO)(agr(yg, 1)) = New Dictionary
End If
dic(vTO)(agr(yg, 1))(yg) = Empty
Next
End If
End If
End If
Next
Set GetDicOtda = dic
End Function
|
