Macro to compare old prices with new prices for stock and show(-/+)

[KalilMe]

Hello,
in QW sheet will be multiple columns contain prices and every time I will add new column contain new prices .
in STOCK sheet contains data in columns A:E
what I want create report in columns G:L with formatting and borders by brings the prices from last column in QW sheet and put in column J , as to column K=column I* column J
column L =column K- column E
in lastrow for column G when amount is minus in column L then populate LOSE word ,amount is plus in column L then populate PROFIT word.
if there is empty cell in last column in QW when brings price from previous column(not the first column) for instance if there is price in columnL,M,N and if the id doesn't existed price in column N then will brings from column M .
when create report will match BATCH column for two sheets , also if there is ID in STOCK sheet and it's not existed in QW sheet then will show as in STOCK sheet.

subtra.xlsm
	J	K	L	M
1	ITEM	BATCH	01/11/2024	02/11/2024
2	1	APP PP FRUIT	12.00	11.00
3	2	BAN FF FRUIT	9.00
4	3	CU CMC VEG	11.00	11.00
5	4	FRU BANN MU	22.00	23.00
6	5	PI PIA FRUIT	21.00	21.00
7	6	PO PTT VEG	12.00	11.00
8	7	TO TMA VEG	5.00	4.00
9	8	TE TEE FOOD	23.00	18.00
10	9	TRB POT BNG	22.00	24.00
QW

subtra.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	ITEM	BATCH	QTY	UNIT PRICE	TOTAL
2	1	TO TMA VEG	10.00	5.00	50.00
3	2	PO PTT VEG	20.00	10.00	200.00
4	3	BAN FF FRUIT	100.00	12.00	1,200.00
5	4	APP PP FRUIT	100.00	10.00	1,000.00
6	5	PI PIA FRUIT	12.00	22.00	264.00
7	6	TE TEE FOOD	100.00	23.00	2,300.00
8	7	CU CMC VEG	120.00	21.00	2,520.00
9	8	TRB POT BNG	100.00	22.00	2,200.00
10	9	FRU BANN MU	124.00	22.00	2,728.00
11
12
13
14
STOCK

result

subtra.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	ITEM	BATCH	QTY	UNIT PRICE	TOTAL		ITEM	BATCH	QTY	UNIT PRICE	TOTAL	D/P
2	1	TO TMA VEG	10.00	5.00	50.00		1	TO TMA VEG	10.00	4.00	40.00	-10.00
3	2	PO PTT VEG	20.00	10.00	200.00		2	PO PTT VEG	20.00	11.00	220.00	20.00
4	3	BAN FF FRUIT	100.00	12.00	1,200.00		3	BAN FF FRUIT	100.00	9.00	900.00	-300.00
5	4	APP PP FRUIT	100.00	10.00	1,000.00		4	APP PP FRUIT	100.00	11.00	1,100.00	100.00
6	5	PI PIA FRUIT	12.00	22.00	264.00		5	PI PIA FRUIT	12.00	21.00	252.00	-12.00
7	6	TE TEE FOOD	100.00	23.00	2,300.00		6	TE TEE FOOD	100.00	18.00	1,800.00	-500.00
8	7	CU CMC VEG	120.00	21.00	2,520.00		7	CU CMC VEG	120.00	11.00	1,320.00	-1,200.00
9	8	TRB POT BNG	100.00	22.00	2,200.00		8	TRB POT BNG	100.00	24.00	2,400.00	200.00
10	9	FRU BANN MU	124.00	22.00	2,728.00		9	FRU BANN MU	124.00	23.00	2,852.00	124.00
11							LOSE					-1,578.00
12
13
STOCK

Cell Formulas
Range	Formula
L2:L10	L2	=K2-E2
L11	L11	=SUM(L2:L10)

I need macro , I don't PQ or PT , formulas
thanks

 

[Peter_SSs]

A bit hard to understand some of that written information but try this with a copy of your workbook.

Sub PROFITorLOSE()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, j As Long, cols As Long
  Dim OT As Double, GT As Double
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("QW")
    a = .Range("K1").Resize(.Cells(Rows.Count, "K").End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column - 10)
  End With
  cols = UBound(a, 2)
  For i = 2 To UBound(a)
    For j = cols To 2 Step -1
      If Len(a(i, j)) > 0 Then
        d(a(i, 1)) = a(i, j)
        Exit For
      End If
    Next j
  Next i
  With Sheets("STOCK")
    a = .Range("A1:F1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1).Value
    a(1, 6) = "D/P"
    For i = 2 To UBound(a) - 1
      a(i, 4) = d(a(i, 2))
      OT = a(i, 5)
      a(i, 5) = a(i, 3) * a(i, 4)
      a(i, 6) = a(i, 5) - OT
      GT = GT + a(i, 6)
    Next i
    a(UBound(a), 6) = GT
    a(UBound(a), 1) = IIf(GT >= 0, "PROFIT", "LOSE")
    With .Range("G1").Resize(UBound(a), 6)
      .Value = a
      .Columns(3).Resize(, 4).NumberFormat = "#,##0.00"
      Union(.Rows(1), .Cells(UBound(a), 1)).Font.Bold = True
      .Columns.AutoFit
    End With
  End With
End Sub

 

[Fuji]

Sub test()
    Dim s$(1), i&, r As Range, c As Range, ws As Worksheet
    Set ws = Sheets("stock")
    ws.Columns("g:l").Clear
    With Sheets("qw").[a1].CurrentRegion
        Set r = .Columns(.Columns.Count + 1)
        r.Cells(1) = "UP"
        r.Cells(2).Resize(r.Rows.Count - 1).Formula2R1C1 = _
        Replace("=index(#,max(if(#<>"""",column(c3:c[-1])-2)))", "#", "rc3:rc[-1]")
    End With
    s(1) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=Yes';"
    s(0) = "Select A.`ITEM`, A.`BATCH`, A.`QTY`, B.`UP` As `UNIT PRICE`, " & _
        "A.`QTY` * B.`UP` As `TOTAL`, A.`QTY` * B.`UP` - A.`TOTAL` As `D/P` " & _
        "From `STOCK$` As A Left Join `QW$` As B On A.`BATCH` = B.`BATCH`;"
    With CreateObject("ADODB.Recordset")
        .Open s(0), s(1), 3, 3, 1
        For i = 0 To .Fields.Count - 1
            ws.Cells(1, i + 7) = .Fields(i).Name
        Next
        ws.[g2].CopyFromRecordset .DataSource
    End With
    r.Clear
    With ws.[g1].CurrentRegion
        .HorizontalAlignment = xlCenter
        .Columns("d:l").NumberFormat = "#,0.00"
        Union(.Rows(1), .Rows(.Rows.Count + 1)).Font.Bold = True
        Set c = .Cells(.Rows.Count + 1, .Columns.Count)
        c.Formula = "=sum(r2c:r[-1]c)"
        .Cells(.Rows.Count + 1, 1) = IIf(c > 0, "GAIN", "LOOSE")
        .EntireColumn.AutoFit
        .Resize(.Rows.Count + 1).Borders.Weight = 2
    End With
End Sub

 

[KalilMe]

A bit hard to understand some of that written information

maybe expression is bad ,sorry !
after testing obviously every thing is perfect .
just I would create borders, I would a slight modification if you don't mind, please.
I would show average price instead of brings price from last column in QW sheet.
example for ID "TE TEE FOOD" QW sheet=18 and the price in stock sheet=23 so when show in result will be average(18,23)=21
thanks

 

[KalilMe]

@Fuji
thanks for writing code for me .
but unfortunately shows error

 

[Peter_SSs]

just I would create borders, I would a slight modification if you don't mind, please.
I would show average price instead of brings price from last column in QW sheet.
example for ID "TE TEE FOOD" QW sheet=18 and the price in stock sheet=23 so when show in result will be average(18,23)=21

Like this?

Sub PROFITorLOSE_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, j As Long, cols As Long
  Dim OT As Double, GT As Double
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("QW")
    a = .Range("K1").Resize(.Cells(Rows.Count, "K").End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column - 10)
  End With
  cols = UBound(a, 2)
  For i = 2 To UBound(a)
    For j = cols To 2 Step -1
      If Len(a(i, j)) > 0 Then
        d(a(i, 1)) = a(i, j)
        Exit For
      End If
    Next j
  Next i
  With Sheets("STOCK")
    a = .Range("A1:F1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1).Value
    a(1, 6) = "D/P"
    For i = 2 To UBound(a) - 1
      a(i, 4) = (d(a(i, 2)) + a(i, 4)) / 2
      OT = a(i, 5)
      a(i, 5) = a(i, 3) * a(i, 4)
      a(i, 6) = a(i, 5) - OT
      GT = GT + a(i, 6)
    Next i
    a(UBound(a), 6) = GT
    a(UBound(a), 1) = IIf(GT >= 0, "PROFIT", "LOSE")
    With .Range("G1").Resize(UBound(a), 6)
      .Value = a
      .Columns(3).Resize(, 4).NumberFormat = "#,##0.00"
      Union(.Rows(1), .Cells(UBound(a), 1)).Font.Bold = True
      .Columns.AutoFit
      .Borders.LineStyle = xlContinuous
    End With
  End With
End Sub

 

[KalilMe]

ok seem to works except one problem , if there is new ID in stock sheet without it's existed in QW sheet then shouldn't Calculate average . should keep the price as it.

subtra.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	ITEM	BATCH	QTY	UNIT PRICE	TOTAL		ITEM	BATCH	QTY	UNIT PRICE	TOTAL	D/P
2	1	TO TMA VEG	10.00	5.00	50.00		1	TO TMA VEG	10.00	24.50	245.00	195.00
3	2	PO PTT VEG	20.00	10.00	200.00		2	PO PTT VEG	20.00	32.50	650.00	450.00
4	3	BAN FF FRUIT	100.00	12.00	1,200.00		3	BAN FF FRUIT	100.00	10.50	1,050.00	-150.00
5	4	APP PP FRUIT	100.00	10.00	1,000.00		4	APP PP FRUIT	100.00	14.00	1,400.00	400.00
6	5	PI PIA FRUIT	12.00	22.00	264.00		5	PI PIA FRUIT	12.00	44.00	528.00	264.00
7	6	TE TEE FOOD	100.00	23.00	2,300.00		6	TE TEE FOOD	100.00	178.00	17,800.00	15,500.00
8	7	CU CMC VEG	120.00	21.00	2,520.00		7	CU CMC VEG	120.00	19.00	2,280.00	-240.00
9	8	TRB POT BNG	100.00	22.00	2,200.00		8	TRB POT BNG	100.00	27.50	2,750.00	550.00
10	9	ASD FGG TR	124.00	10.00	2,728.00		9	ASD FGG TR	124.00	5.00	620.00	-2,108.00
11	10	FRU BANN MU	124.00	22.00	2,728.00		10	FRU BANN MU	124.00	22.50	2,790.00	62.00
12							PROFIT					14,923.00
STOCK

the right

subtra.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	ITEM	BATCH	QTY	UNIT PRICE	TOTAL		ITEM	BATCH	QTY	UNIT PRICE	TOTAL	D/P
2	1	TO TMA VEG	10.00	5.00	50.00		1	TO TMA VEG	10.00	24.50	245.00	195.00
3	2	PO PTT VEG	20.00	10.00	200.00		2	PO PTT VEG	20.00	32.50	650.00	450.00
4	3	BAN FF FRUIT	100.00	12.00	1,200.00		3	BAN FF FRUIT	100.00	10.50	1,050.00	-150.00
5	4	APP PP FRUIT	100.00	10.00	1,000.00		4	APP PP FRUIT	100.00	14.00	1,400.00	400.00
6	5	PI PIA FRUIT	12.00	22.00	264.00		5	PI PIA FRUIT	12.00	44.00	528.00	264.00
7	6	TE TEE FOOD	100.00	23.00	2,300.00		6	TE TEE FOOD	100.00	178.00	17,800.00	15,500.00
8	7	CU CMC VEG	120.00	21.00	2,520.00		7	CU CMC VEG	120.00	19.00	2,280.00	-240.00
9	8	TRB POT BNG	100.00	22.00	2,200.00		8	TRB POT BNG	100.00	27.50	2,750.00	550.00
10	9	ASD FGG TR	124.00	10.00	2,728.00		9	ASD FGG TR	124.00	10.00	620.00	-2,108.00
11	10	FRU BANN MU	124.00	22.00	2,728.00		10	FRU BANN MU	124.00	22.50	2,790.00	62.00
12							PROFIT					14,923.00
STOCK

and should delete the data for columns G:L before update data because I notice the code will leave some formatting I don't need it depending on increase or decrease data for stock sheet.

 

[kvsrinivasamurthy]

TRy this Code.

Sub CreateTable()
Application.ScreenUpdating = False
Dim Lrq&, Lrs&, Lcs&, T&
Dim Frng1 As Range, Frng2 As Range

Lrq = Sheets("QW").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("STOCK")
Lrs = .Range("A" & Rows.Count).End(xlUp).Row
Lcs = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A1").CurrentRegion.Resize(, 3).Copy .Range("G1")
For T = 2 To Lrs
Set Frng1 = Sheets("QW").Range("B2:B" & Lrq).Find(.Range("H" & T).Value)
If Not Frng1 Is Nothing Then
.Range("J" & T) = Sheets("QW").Cells(Frng1.Row, Lcs + 1).End(xlToLeft)
End If
Next T
.Range("K2:K" & Lrs).Formula = "=I2*J2"
.Range("L2:L" & Lrs).Formula = "=K2-e2"
.Range("G1:J1").Copy .Range("J1")
.Range("J1:L1") = Array("UNIT PRICE", "TOTAL", "D/P")
.Range("H1").CurrentRegion.Borders.LineStyle = xlContinuous
End With

Application.ScreenUpdating = True
End Sub

 

[KalilMe]

TRy this Code.

Hi,
this is what I got.

subtra.xlsm
	G	H	I	J	K	L
1	ITEM	BATCH	QTY	UNIT PRICE	TOTAL	D/P
2	1	TO TMA VEG	10.00		0	-50.00
3	2	PO PTT VEG	20.00		0	-200.00
4	3	BAN FF FRUIT	100.00		0	-1,200.00
5	4	APP PP FRUIT	100.00		0	-1,000.00
6	5	PI PIA FRUIT	12.00		0	-264.00
7	6	TE TEE FOOD	100.00		0	-2,300.00
8	7	CU CMC VEG	120.00		0	-2,520.00
9	8	TRB POT BNG	100.00		0	-2,200.00
10	9	ASD FGG TR	124.00		0	-2,728.00
11	10	FRU BANN MU	124.00		0	-2,728.00
STOCK

Cell Formulas
Range	Formula
K2:K11	K2	=I2*J2
L2:L11	L2	=K2-E2

 

[Fuji]

try change

    With Sheets("qw").[a1].CurrentRegion
        Set r = .Columns(.Columns.Count + 1)
        r.Cells(1) = "UP"
        r.Cells(2).Resize(r.Rows.Count - 1).Formula2R1C1 = _
        Replace("=index(#,max(if(#<>"""",column(c3:c[-1])-2)))", "#", "rc3:rc[-1]")
    End With

to

    With Sheets("qw").[a1].CurrentRegion
        Set r = .Columns(.Columns.Count + 1)
        r.Cells(1) = "UP"
        r.Cells(2).FormulaArray = Replace("=index(#,max(if(#<>"""",column(c3:c[-1])-2)))", "#", "rc3:rc[-1]")
        r.Cells(2).Resize(r.Rows.Count - 1).FillDown
    End With