Помимо ошибок кодирования с отсутствующими Range
'Loop While (qty > Range("AQ" & j).Value And ("A" & i).Value = Range("AP" & j).Value)
Loop While (qty > Range("AQ" & j).Value And Range("A" & i).Value = Range("AP" & j).Value)
и отсутствующими End If между Loop и Next j, логика c имеет недостатки.
Внутри l oop значение j не изменяется, поэтому сумма рассчитывается по цене первого найденного предмета независимо от доступного количества. Значение l oop не требуется и должно быть удалено.
Кроме того, если количество меньше, чем имеющееся, цена рассчитывается с использованием доступного количества (не требуемого количества), а требуемое количество не изменяется.
If qty > Range("AQ" & j).Value Then
' range copy
mySum = mySum + Range("AQ" & j).Value * Range("AV" & j).Value
qty = qty - Range("AQ" & j).Value
Else
' range copy
mySum = mySum + Range("AQ" & j).Value * Range("AV" & j).Value
End If
должно быть
If qty > Range("AQ" & j).Value Then
' range copy
mySum = mySum + Range("AQ" & j).Value * Range("AV" & j).Value
qty = qty - Range("AQ" & j).Value
Else
' range copy
mySum = mySum + qty * Range("AV" & j).Value
qty = 0
End If
Обратите внимание, что сумма будет неправильной, если общее доступное количество меньше требуемого количества.
Это объявление будет лучше, чем Long
' Dim i, j, qty As Integer
Dim i as Long, j as Long, qty as Long
, поскольку оно не будет выполнено, если qty > 32767
Этот код записывает сумму для каждой части в столбец D
Sub ExitFor_Loop2()
Const SHEET_NAME = "Sheet1" ' change as required
Const COL_PART = "A"
Const COL_QU = "C"
Const COL_SUM = "D" ' sum for each part change as required
Const COL_STOCKPART = "AP"
Const COL_STOCKQU = "AQ"
Const COL_STOCKPRICE = "AV"
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long
Dim t0 As Single, count As Long
t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
Dim iQu As Long, dSum As Double, sPart As String
Dim iStockRow As Long, iStockQu As Long, dStockPrice As Double
Dim iLastStock As Long
iLastStock = ws.Range(COL_STOCKPART & Rows.count).End(xlUp).Row
iLastRow = ws.Range(COL_PART & Rows.count).End(xlUp).Row
'Debug.Print iLastRow, iLastStock
' double loop
Application.ScreenUpdating = False
For iRow = 2 To iLastRow
sPart = ws.Cells(iRow, COL_PART)
iQu = ws.Cells(iRow, COL_QU)
dSum = 0
For iStockRow = 2 To iLastStock
' matching part no
If sPart = ws.Cells(iStockRow, COL_STOCKPART) Then
iStockQu = ws.Cells(iStockRow, COL_STOCKQU) 'qu
dStockPrice = ws.Cells(iStockRow, COL_STOCKPRICE) 'price
With ws.Rows(iStockRow)
.Columns("BC") = sPart
.Columns("BD").Value = .Columns("AT").Value
.Columns("BE").Value = .Columns("AQ").Value
.Columns("BF:BJ").Value = .Columns("AV:AZ").Value
End With
If iQu > iStockQu Then
dSum = dSum + iStockQu * dStockPrice
iQu = iQu - iStockQu
Else
dSum = dSum + iQu * dStockPrice
iQu = 0
iStockRow = iLastStock ' end search
End If
End If
count = count + 1
Next
' not enough stock
If iQu > 0 Then
MsgBox iQu & " items short for " & sPart, vbExclamation, "Part row " & iRow
dSum = 0
End If
ws.Cells(iRow, COL_SUM) = dSum ' sum in coll E
Next
Application.ScreenUpdating = True
MsgBox "Scanned col " & COL_PART & " to row " & iRow - 1, vbInformation, _
count & " iterations completed in " & Format(Timer - t0, "0.00") & " secs"
End Sub
~~~