Here is my "IN" List -
PN Qty Price
A 100 5
B 150 6
C 150 7
D 50 -9
E 100 5
F 5 9
G 20 6
I 5 7
J 15 7
J 30 10
K 100 10
K 50 10
A 20 8
Here is my "OUT" List -
PN Qty
A 120
B 10
C 110
D 60
E 100
J 20
J 10
Expected Results -
Manual Formula to calculate Price for PN = "A" = ((100*5)+(20*8))/120
PN Qty Price Total
A 120 5.5 660
B 10 6 60
C 110 7 770
D 60 -9 -540
E 100 5 500
J 20 7.75 155
J 10 10 100
I want to implement FIFO logic to calculate the Total Price in "OUT" List based on "Quantity" in "IN" List.
When you have tables like this, the outgoing button with following code:
Private Sub Outgoing_Click()
Dim pn As String
Dim ammout As Long
Dim current As Long
pn = InputBox("Which Item do you want to take out?")
ammount = InputBox("How Item do you want to take out?")
Dim cells As Long
Dim fifo As Double
counter = 1 //line where your table starts
current = 0
fifo = 0
Do Until IsEmpty(cells(counter, 13).Value Or current = ammount)
If cells(counter, 13).Value = pn Then
If cells(counter, 14).Value > (ammount - current) Then
fifo = fifo + (ammount - current) * cells(current, 15).value
current = ammount
Else
fifo = fifo + cells(counter, 14).Value * cells(counter, 15).Value
current = current + cells(counter, 14)
cells(counter, 14).Value = 0
End If
counter = counter + 1
Loop
fifo = fifo / ammount
End Sub
Should be work.
I did not match lie if you have enough in your current list and others so the validation part is missing.
your "Expected Results" doesn't match your "Manual Formula"
following this latter
Option Explicit
Sub main()
Dim cell As Range
Dim dictSum As Object
Dim dictRept As Object
Set dictSum = CreateObject("Scripting.Dictionary")
Set dictRept = CreateObject("Scripting.Dictionary")
With Worksheets("IN")
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
dictSum(cell.Value) = dictSum(cell.Value) + cell.Offset(, 1).Value * cell.Offset(, 2).Value
dictRept(cell.Value) = dictRept(cell.Value) + cell.Offset(, 1).Value
Next
End With
With Worksheets("OUT")
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
cell.Offset(, 2) = dictSum(cell.Value) / dictRept(cell.Value)
cell.Offset(, 3) = cell.Offset(, 1) * cell.Offset(, 2)
Next
End With
End Sub
Related
Good afternoon,
I'm wondering if anyone knows of a better approach for finding the extended quantity of a row (based on level.) The dataset looks similar to this:
Level
Component
Quantity
ExtQty (formula)
Purchase
1
complete component 1
2
2
M
2
component 2
4
8
P
3
component 3
4
0
M
2
component 4
4
8
M
3
component5
10
80
M
1
complete component 2
1
1
M
2
component2
4
4
P
3
component3
4
0
M
2
component8
4
4
M
3
component9
10
40
M
I'm using:
=#IF(A2-1<1,C2,IF(XLOOKUP(A2-1,$A$2:$A2,$E$2:$E2,"ERR",0,-1)="P",0,XLOOKUP(A2-1,$A$2:$A2,$D$2:$D2,"ERR",0,-1)*$C2))
Currently it's still inserting over 184,000 rows and it's been about 50 minutes, still going...
(edit: finished at 53 minutes)
The goal is to take the quantity and multiply it with the quantity of the levels above. If the parent is a purchase part, set quantity to 0.
Does anyone have any tips to make this a little faster, other than working with a smaller dataset?
It seems to me that the table does not express the same behavior in each row, for example, I understand that in Level 3 = 10 * 2 * 2 * 2 = 80, but the Level 2 = 4 * 2. It does not have a fixed rule. In case you want to use the first it's "=POWER(2;A6)*C6" and otherwise "=POWER(2;A5-1)*C5"
I've decided to go with VBA. Currently running 184000 rows in 20 seconds rather than 53 minutes.
I'm not great at VBA, but this is what I came up with:
Sub ExtQty()
Dim cell As Range
Dim sheet As Worksheet
Dim levelStack, stopStack As Object
Dim lvlCol, extQtyCol, qtyCol, procCol, bomCol, itemCol, compCol As Integer
Dim Progress As Double
Dim i, j As Long
Set sheet = Application.ActiveSheet
ProgressForm.Show (vbModeless)
lRow = lastRow()
qtyCol = GetColumn("Quantity")
extQtyCol = qtyCol + 1
sheet.Columns(extQtyCol).Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
sheet.Cells(1, extQtyCol).Value = "ExtQty"
lvlCol = GetColumn("Level") 'after ExtQty insert for correct column
procCol = GetColumn("Procurement")
compCol = GetColumn("Component")
itemCol = GetColumn("Item")
Set levelStack = CreateObject("System.Collections.Stack")
sheet.Range(Cells(2, itemCol), Cells(lRow, itemCol)).Font.Bold = True
sheet.Range(Cells(2, compCol), Cells(lRow, compCol)).Font.Bold = True
sheet.Range(Cells(2, extQtyCol), Cells(lRow, extQtyCol)).Font.Bold = True
i = 1
For Each cell In sheet.Range(sheet.Cells(2, lvlCol), sheet.Cells(lRow, lvlCol))
Call ProgressForm.Progress(i, cell.Row, lRow, 1000) 'every 1000 loops; every loop hurts performance
If cell.Offset(1, 0).Value > cell.Value Then 'push parent level onto stack
If cell.Value = 1 Then
sheet.Cells(cell.Row(), extQtyCol).Value = sheet.Cells(cell.Row(), qtyCol).Value
Else
If levelStack.Peek()(1) = "F" Then
sheet.Cells(cell.Row(), extQtyCol).Value = 0
Else
sheet.Cells(cell.Row(), extQtyCol).Value = sheet.Cells(cell.Row(), qtyCol).Value * levelStack.Peek()(0)
End If
End If
levelStack.Push Array(sheet.Cells(cell.Row(), extQtyCol).Value, sheet.Cells(cell.Row(), procCol).Value)
ElseIf cell.Offset(1, 0).Value < cell.Value Then 'check if leaving current level and pop
If cell.Value = 1 Then
sheet.Cells(cell.Row(), extQtyCol).Value = sheet.Cells(cell.Row(), qtyCol).Value
If cell.Row >= lRow Or cell.Offset(1, 0).Value = "" Then 'fixed error if last row AND level 1
Exit For
End If
ElseIf levelStack.Peek()(1) = "F" Then
sheet.Cells(cell.Row(), extQtyCol).Value = 0
Else
sheet.Cells(cell.Row(), extQtyCol).Value = levelStack.Peek()(0) * sheet.Cells(cell.Row(), qtyCol).Value
End If
If cell.Value > cell.Offset(1, 0).Value Then
diff = cell.Value - cell.Offset(1, 0).Value
End If
For j = 1 To diff 'used for when level drops more than one level
If cell.Row() = lRow Then
topStack = levelStack.Clear()
Exit For
Else
topStack = levelStack.Pop()
End If
Next
Else 'All others - don't push or pop
If cell.Value = 1 Then
sheet.Cells(cell.Row(), extQtyCol).Value = sheet.Cells(cell.Row(), qtyCol).Value
ElseIf levelStack.Peek()(1) = "F" Then
sheet.Cells(cell.Row(), extQtyCol).Value = 0
Else
sheet.Cells(cell.Row(), extQtyCol).Value = levelStack.Peek()(0) * sheet.Cells(cell.Row(), qtyCol).Value
End If
End If
sheet.Cells(cell.Row(), extQtyCol) = Round(sheet.Cells(cell.Row(), extQtyCol), 3)
Next
ProgressForm.Hide
End Sub
I have the values on the range "A1:O1".
Each Column has a unique value in this range.
I need help to develop a loop that will fill down 04 times on each column the same Top Value (Column Value). Below a Pseudo Code
Sub FillDownRowsRandomly()
Dim i As Integer, j As Integer
'RamdomRow=Total of 04 unique ramdom numbers
'choosen from 01 to 06 {1,2,3,4,5,6}
'meaning that in a loop of 6 interations, when fill down
'2 will be Null or empty
'
For i = 1 To 15 'Columns "A" To "O"
For j = 2 To 7 '
'
Cells(RandomRow, i).Value = Cells(1, i).Value
Next j
Next i
End Sub
Below an Image where will be possible identify the result of the code.
Disregard the "Null" word written in the cells. I wrote that just to clarify that during the random loop, the code "ignored that cell".
Maybe something like:
Sub FillDownRowsRandomly()
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
End Sub
Loop the columns and randomly place the values till there are four in the six rows.
Sub FillDownRowsRandomly()
ActiveSheet.Range("A2:O7").ClearContents
Dim i As Long
For i = 1 To 15 'iterate the columns
Do Until Application.CountIf(ActiveSheet.Cells(2, i).Resize(6), ActiveSheet.Cells(1, i).Value) >= 4
Dim j As Long
j = Application.RandBetween(2, 7)
ActiveSheet.Cells(j, i).Value = ActiveSheet.Cells(1, i).Value
Loop
Next i
End Sub
So I'm doing a Minesweeper game for a class and everything is going fine more or less, however I had encountered a problem. Sometimes the Mines are being places in the same cell. I.e.: If i have 10 bombs sometimes 9 bombs would be displayed.
Here is my Code so far:
Sub Minesweeper()
Dim Mines As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim OverLap As Integer
'This is for Centering Text
For i = 8 To 15
For j = 6 To 13
Cells(i, j).HorizontalAlignment = xlCenter
Next j
Next i
'This is for setting Table/Board
For i = 8 To 15
For j = 6 To 13
'By default all cells will = 1 until bomb is placed
Cells(i, j).Value = 1
Next j
Next i
'This generates certain Number of Mines
For Mines = 1 To 10
Cells(((Int((15 - 8 + 1) * Rnd + 1)) + 7), ((Int((13 - 6 + 1) * Rnd + 1))) + 5).Value = 0
Next Mines
'This is for converting Mines to o and color change
For i = 8 To 15
For j = 6 To 13
If Cells(i, j).Value = 0 Then
Cells(i, j).Value = "o"
Cells(i, j).Font.Color = RGB(250, 0, 0)
ElseIf Cells(i, j).Value >= 1 Then
Cells(i, j).Font.Color = RGB(0, 0, 0)
End If
Next j
Next i
End Sub
Do an 'If' check of values during for Mines = 1 to 10. Declare your cell values first then check if that cell is a 1. If it is then place the 0. If it isn't then generate another random cell and recheck.
For Mines = 1 To 10
1
x = Int((15 - 8 + 1) * Rnd + 1) + 7
y = Int((13 - 6 + 1) * Rnd + 1) + 5
If Cells(x, y).Value = 1 Then
Cells(x, y).Value = 0
Else:
GoTo 1
End If
Next Mines
I have written the code below in which I have to first identify smallest, 2nd smallest and so on numbers and then obtain the row numbers for them (I am saving the row numbers in a separate column, here column 50, in case there are more than one such number) and copy contents from one column (Here column 2) to another (Here Column 7) in the order of the row numbers, i.e. Smallest first, then 2nd smallest, and so on.
There are 172 such data sets starting at every 43 rows
This will continue till the sum of the numbers in the new column (45 row of Column 7 of each dataset) (To which the data is copied) is less than a specified number (45 row of Column 1 in every data set, i.e., A45 then A88)
EDIT: The sums being compared above, i.e. G45 is compared to A45 is through formula in the sheet itself
Dim m As Range, cl As Range, k As Double, b As Double, lIndex As Double, a As Double, multi As Double, l As Integer, x As Double
Set m = ActiveSheet.Range("E3:E40")
multi = 2 'To move to starting position of the data set
For i = 1 To 172
b = 45 + 43 * (i - 1)
For k = 1 To 38
a = Application.Small(m, k) 'To find the kth smallest number
l = 1
For j = 1 To 38 'To store the matching row numbers (Multiple instances) in column 50
Cells(j, 50).Value = 0 'Initializing to column no. 50 to 0
If Cells(j + multi, 5).Value = a Then 'Checking for match
Cells(l, 50).Value = j + multi 'Storing Row coordinates in column no. 50
l = l + 1
End If
Next j
'==============THE FOLLOWING IS THE AREA WHERE THE PROBLEM MIGHT BE======================
For o = 1 To l - 1 'To Copy the values based on the criteria
x = Cells(o, 50).Value
If Cells(b, 7).Value <= Cells(b, 1).Value Then '"CRITERIA" Checking whether sum of the column is less than or equal to sum of first column of set
Cells(x, 7).Value = Cells(x, 2).Value
End If
Next o
Next k
Set m = m.Offset(43)
multi = multi + 43
Next i
The problem is that the condition for copying copy (The sum should be less than certain value) is not working. It actually copies all the data from column 2 to column 7.
Can someone help in finding what might be the reason for this...
NOTE: I checked and confirmed that the code to store row numbers in column 50 is working fine. So the problem might be in the lower half of the code which is the for loop with variable "o"
I went ahead and pushed this myself with this.
Realized there were multiple mistakes:
I had to initialize the new column to 0. That I missed. Changed column from 7 to 6 due to some reasons.
I did not exit the main for-loop when the criteria was reached due to which the process went on even after the process was supposed to be complete. Used the Boolean variable flag for this.
While counting for the iterations involving the repetition of the value given by small function, the variable "l" was counted one +1. Made suitable adjustments. (Changed column from 50 to 500 due to some reason)
I observed that Excel was not updating the calculated valued by itself, so included Application.Calculate function at the beginning.
Here is the working code:
Application.Calculate
Dim m As Range, cl As Range, k As Double, b As Double, lIndex As Double, a As Double, multi As Double, l As Double, x As Double, Check As Double, flag As Boolean
l = 2
Set m = ActiveSheet.Range("E3:E40")
multi = 2 'To move to starting position of the data set
flag = False
For i = 1 To 172
b = 45 + 43 * (i - 1)
Cells(b, 6).Value = 0
For p = 3 To 40
Cells(p + ((i - 1) * 43), 6).Value = 0 'Initializing to column no. 6 to 0
Next p
For k = 1 To 38
If flag = True Then
flag = 0
Exit For
End If
If k + l - 2 <= 38 Then
a = Application.Small(m, (k + l - 2))
k = k + l - 2
Else
Exit For
End If
l = 1
For j = 1 To 38
Cells(j, 500).Value = 0 'Initializing to column no. 500 to 0
If Cells(j + multi, 5).Value = a Then 'Checking for match
Cells(l, 500).Value = j + multi 'Storing Row coordinates in column no. 500
l = l + 1
End If
Next j
For o = 1 To l - 1
x = Cells(o, 500).Value
Cells(x, 6).Value = 0
Cells(b, 6).Value = Cells(b, 6).Value + Cells(x, 2).Value
Check = Cells(b, 6).Value
If Cells(b, 6).Value <= Cells(b, 1).Value Then 'Checking whether sum of the column is less than or equal to sum of first column of set
Cells(x, 6).Value = Cells(x, 2).Value
Else:
Cells(x, 6).Value = Cells(b, 1).Value - (Cells(b, 6).Value - Cells(x, 2).Value)
Cells(b, 6).Value = Cells(b, 6).Value - Cells(x, 2).Value + Cells(x, 6).Value
flag = True
Exit For
End If
Next o
Next k
Set m = m.Offset(43)
multi = multi + 43
Next i
End Sub
I have an Excel-Sheet with values in column D.
I would like to set the row height in relation to the value of cell D of each row.
Values in D are small %-values like 0.0593 %, except of the first (D4 = 31 %) and last (D92 = 40 %)
To get the small values at a reasonable height I'd like to multiply them with 10'000 - but there comes the problem with the 409 max height.
I have a script that works until it comes to the high values so I tried a if formula. But to be frankly: I have no Idea what I am doing here... I copied it together.
So the problems: working only in the range of D5-D91 and if a value should go over 409 give him something like 15px.
Thanx for your Help!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row - 1
With Cells(i, 4)
If .Cells(i, 4).Value * 10000 > 409 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 10000
End If
End With
Next i
End Sub
Copy the below code to any standard module & Run. You may have to tweak the code as per your requirement.
Sub sample()
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 4).Value * 10000 > 409 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 10000
End If
Next
End Sub
Sub sample()
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 4).Value * 100000 > 409 Then
Rows(i).RowHeight = 20
ElseIf Cells(i, 4).Value * 100000 < 10 Then
Rows(i).RowHeight = 12
Else
Rows(i).RowHeight = Cells(i, 4).Value * 100000
End If
Next
End Sub