Hello Baziwan,
This macro works correctly on the sample workbook. The code is written to allow for 1 or more warehouses. The warehouse name must contain the word " Bond " in the row 1 headers. The macro also determines the last entry made in the database. Your table can grow and the macro will not need to be changed. Test this on a copy of the real database and let me know how it works. Here is the macro that has been added to the button on the "Database" worksheet.
'Written: Spetmeber 28, 2010
'Author: Leith Ross (www.excelforum.com)
Sub CreateDeliveryRequest()
Dim C As Long
Dim DataRng As Range
Dim DataWks As Worksheet
Dim I As Long
Dim LastCol As Long, LastRow As Long
Dim MaxStock As Double, MinStock As Double
Dim N As Long
Dim OrderQty As Double
Dim Product As Variant
Dim Qty As Double
Dim R As Long
Dim Remainder As Double
Dim Rqstwks As Worksheet
Dim ThisOrder As Double
Dim WareHouses() As Variant
Dim WarehouseQty As Double
Set Rqstwks = Worksheets("Delivery Request")
Set DataWks = Worksheets("Database")
LastCol = DataWks.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = DataWks.Cells(Rows.Count, "A").End(xlUp).Row
If LastRow = 1 Then Exit Sub
Set DataRng = DataWks.Range("A2", DataWks.Cells(LastRow, LastCol))
With DataWks
For C = 1 To LastCol
If .Cells(1, C) Like "* Bond *" Then
N = N + 1
ReDim Preserve WareHouses(1 To N)
Set WareHouses(N) = .Range(.Cells(2, C), .Cells(LastRow, C + 2))
End If
Next C
End With
With Rqstwks
N = .Cells(Rows.Count, "A").End(xlUp).Row
If N > 1 Then .Range("A2", .Cells(N, "C")).ClearContents
End With
For Each Product In DataRng.Columns(1).Cells
N = Product.Row - DataRng.Row + 1
Qty = Product.Offset(0, 2)
MinStock = Product.Offset(0, 3)
MaxStock = Product.Offset(0, 4)
OrderQty = MaxStock - Qty
For I = 1 To UBound(WareHouses)
If WareHouses(I).Item(N, 1) > 0 Then
WarehouseQty = WareHouses(I).Item(N, 1)
Remainder = WarehouseQty - OrderQty
ThisOrder = IIf(Remainder < 0, OrderQty + Remainder, OrderQty)
WarehouseQty = IIf(Remainder < 0, 0, Remainder)
OrderQty = WarehouseQty - Remainder
If ThisOrder > 0 Then
With Rqstwks.Range("A2")
.Offset(R, 0) = Product
.Offset(R, 1) = WareHouses(I).Item(N, 2)
.Offset(R, 2) = ThisOrder
End With
WareHouses(I).Item(N, 1) = WarehouseQty
R = R + 1
End If
End If
Next I
Next Product
End Sub
Bookmarks