adjusting code or alternative on userform to change way of price average calculation

KalilMe

Active Member
Joined
Mar 5, 2021
Messages
400
Office Version
  1. 2016
Platform
  1. Windows
hello,
this is original thread

combining data in listbox on userform across multiple sheets and calculate values amongst them
and I add TOTAL columns in STA sheet
KM.xlsm
ABCDEFGHIJ
1ITEMIDBRTYORQTYUNIT COSTUNIT SALECOST TOTALSALES TOTAL
21FR-1FRBANANATT200.0010.0015.002,000.0003,000.00
32FR-2FRAPPLELL100.0011.0017.001,100.0001,700.00
43FR-3FRPEARNN60.0012.0015.00720.000900.00
54FR-4FRBANANAQQ55.0013.0017.00715.000935.00
65VEG1VEGTOMATOSS50.0014.0016.00700.000800.00
76VEG2VEGTOMATOAA50.0011.0015.00550.000750.00
87FR-5FR1PEARMM20.009.0018.00180.000360.00
98FR-6FR2PEARMM20.0010.0018.00200.000360.00
STA
Cell Formulas
RangeFormula
I2:I9I2=F2*G2
J2:J9J2=H2*F2


others sheets keep the same structure as in original thread
KM.xlsm
ABCDEFGH
1DATEIDBRTYORQTYUNIT COSTTOTAL
201/01/2021FR-1FRBANANATT100.0012.001,200.00
301/02/2021FR-2FRAPPLELL50.0015.00750.00
401/03/2021FR-3FRPEARNN60.0012.00720.00
501/04/2021FR-4FRBANANAQQ60.0013.00780.00
601/05/2021VEG1VEGTOMATOSS65.0014.00910.00
701/06/2021VEG2VEGTOMATOAA40.0011.00440.00
801/07/2021FR-1FRBANANATT100.0013.001,300.00
901/08/2021FR-5FR1PEARMM55.0014.00770.00
RPA
Cell Formulas
RangeFormula
H2:H9H2=G2*F2



KM.xlsm
ABCDEFGH
1DATEIDBRTYORQTYUNIT SALETOTAL
202/01/2021FR-1FRBANANATT5.0015.0075.00
302/03/2021FR-3FRPEARNN5.0015.0075.00
402/04/2021FR-4FRBANANAQQ2.0017.0034.00
502/05/2021VEG1VEGTOMATOSS3.0016.0048.00
602/06/2021VEG2VEGTOMATOAA4.0015.0060.00
702/08/2021FR-5FR1PEARMM2.0015.0030.00
802/08/2021FR-5FR1PEARMM2.0020.0040.00
SR
Cell Formulas
RangeFormula
H2:H8H2=G2*F2



KM.xlsm
ABCDEFGH
1DATEIDBRTYORQTYPRICETOTAL
203/01/2021FR-1FRBANANATT2.0015.0030.00
303/02/2021FR-3FRPEARNN2.0015.0030.00
403/03/2021FR-1FRBANANATT2.0015.0030.00
503/04/2021FR-3FRPEARNN2.0015.0030.00
RR
Cell Formulas
RangeFormula
H2:H5H2=G2*F2


KM.xlsm
ABCDEFGH
1DATEIDBRTYORQTYPRICETOTAL
201/01/2021FR-1FRBANANATT5.00012.00060.000
301/02/2021FR-2FRAPPLELL10.00011.000110.000
401/03/2021FR-1FRBANANATT15.00012.000180.000
501/04/2021FR-2FRAPPLELL20.00011.000220.000
602/04/2021FR-6FR2PEARMM10.008.0080.000
7
SS
Cell Formulas
RangeFormula
H2:H6H2=G2*F2



what I want sum and subtract TOTAL columns across sheets

the sheets should be =STA+RPA-SS (COLUMNS =TOTAL(I+H-H)) and divide result on QTY for column (10) in listbox
and Sheets should be =STA+SR-RR(COLUMNS =TOTAL(J+H-H)) and divide result on QTY for column (10) in listbox
ex: FR-1 ID= (2000+1200+1300)-(60+220)=4260 / 379=11.24010554 as show in column 11 in listbox
FR-1 ID=(3000+75)-(30+30)=3015/379 as show in column 12 .
here is result
avr.PNG


to reminding what code really does it.
I have many sheets about five sheets contains data are almost 3000 rows for each sheet and it will increase continuously . so what I want when run the userform should merge the duplicate items based on COL B across the sheets each sheet repeat the items except the first sheet because this data collected from previous year. the others sheets are current year operations with considering the second sheet sometimes contains new item then should show in listbox . after merge duplicate items should show the QTY for each sheet . about COL 11 in list box and calculate like this as item (FR1)=200+200-5+4-20=379
as columns 11,12 in list box will calculate price average as I mentioned above
column 13 in list box =columns(12-11)* column(10).
as to selected sheet from combo box should follow the same way when calculation the price average when there is duplicates ID in each sheet alone without calculation across sheets.
the ID is not necessary to be existed in all sheets , sometimes there are new IDs in sheet and not existed in other sheets.


VBA Code:
Sub LoadListbox()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim a As Variant, b() As Variant, c As Variant, d As Variant, e As Variant
  Dim dic As Object
  Dim arSh As Variant, itSh As Variant
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim p As Long, q As Long, u As Long
  Dim x1 As Double, x2 As Double, x3 As Double, y1 As Double, y2 As Double, y3 As Double
  
  Set dic = CreateObject("Scripting.Dictionary")
  'first sheet
  a = Sheets("STA").Range("A2", Sheets("STA").Range("H" & Rows.Count).End(3)).Value
  'second sheet
  d = Sheets("RPA").Range("A1", Sheets("RPA").Range("H" & Rows.Count).End(3)).Value
  'Sheet names, from 2 to last
  arSh = Array("RPA", "SR", "RR", "SS")
  '
  u = UBound(arSh) + 2
  ReDim c(1 To UBound(a, 1) + UBound(d, 1), 1 To 9 + u)
  ListBox1.ColumnCount = 9 + u
  m = 6   'Initial column inside the listbox for the sheets
  '
  'For the first sheet
  For i = 1 To UBound(a)
    dic(a(i, 2)) = i
    For j = 1 To 6 'UBound(a, 2)
      c(i, j) = a(i, j)
    Next
    c(i, m + u) = a(i, 6)       'qty
    c(i, m + u + 1) = "1|" & a(i, 7)   'unit cost
    c(i, m + u + 2) = "1|" & a(i, 8)   'unit sale
    'c(i, m + u + 3) = (c(i, m + u + 2) - c(i, m + u + 1)) * c(i, m + u)
  Next i
  '
  'For the second sheet
  p = dic.Count   'Number of indices
  For i = 2 To UBound(d)
    If Not dic.exists(d(i, 2)) Then
      p = p + 1
      dic(d(i, 2)) = p
      For j = 1 To 5
        c(p, j) = d(i, j)
      Next j
      If d(1, 7) = WorksheetFunction.Trim("UNIT COST") Then
        c(p, m + u + 1) = "1|" & d(i, 7)
      ElseIf WorksheetFunction.Trim("UNIT SALE") Then
        c(p, m + u + 2) = "1|" & d(i, 7)
      End If
    End If
  Next i
  '
  n = 7   'To increase the column for each sheet
  q = 1   'If it's odd or even
  For itSh = 0 To UBound(arSh)
    Set sh = Sheets(arSh(itSh))
    q = q + 1
    Erase b()
    b = sh.Range("A1", sh.Range("H" & Rows.Count).End(3)).Value
    For i = 2 To UBound(b)
      If dic.exists(b(i, 2)) Then
        k = dic(b(i, 2))
        c(k, n) = c(k, n) + b(i, 6)
        If q Mod (2) = 0 Then
          c(k, m + u) = c(k, m + u) + b(i, 6)
        Else
          c(k, m + u) = c(k, m + u) - b(i, 6)
        End If
        
        x1 = Split(c(k, m + u + 1), "|")(0)
        x2 = Split(c(k, m + u + 1), "|")(1)
        y1 = Split(c(k, m + u + 2), "|")(0)
        y2 = Split(c(k, m + u + 2), "|")(1)
        If b(1, 7) = WorksheetFunction.Trim("UNIT COST") Then
          x1 = x1 + 1
          x2 = x2 + b(i, 7)
          c(k, m + u + 1) = x1 & "|" & x2
        ElseIf b(1, 7) = WorksheetFunction.Trim("UNIT SALE") Then
          y1 = y1 + 1
          y2 = y2 + b(i, 7)
          c(k, m + u + 2) = y1 & "|" & y2
        End If
      End If
    Next
    n = n + 1
  Next
  '
  ReDim e(1 To dic.Count, 1 To UBound(c, 2))
  For i = 1 To dic.Count
    For j = 1 To 5
      e(i, j) = c(i, j)
    Next
    For j = 6 To 6 + u
      e(i, j) = Format(c(i, j), "0.00; -0.00; -")
      If e(i, j) = "" Or e(i, j) = 0 Then e(i, j) = "-"
    Next
    
    x1 = Split(c(i, m + u + 1), "|")(0)
    x2 = Split(c(i, m + u + 1), "|")(1)
    If x1 > 0 Then
      x3 = x2 / x1
      e(i, m + u + 1) = Format(x3, "$#,##0.00; -$#,##0.00; -")
    End If
    
    y1 = Split(c(i, m + u + 2), "|")(0)
    y2 = Split(c(i, m + u + 2), "|")(1)
    If y1 > 0 Then
      y3 = y2 / y1
      e(i, m + u + 2) = Format(y3, "$#,##0.00; -$#,##0.00; -")
    End If
    
    e(i, m + u + 3) = Format((y3 - x3) * e(i, m + u), "$#,##0.00; -$#,##0.00; -")
  Next
  ListBox1.RowSource = ""
  ListBox1.List = e
End Sub

Private Sub ComboBox1_Change()
  With ComboBox1
    If .Value = "" Then
      Call LoadListbox
      Exit Sub
    End If
    
    If .ListIndex = -1 Then Exit Sub
    ListBox1.RowSource = ""
    ListBox1.Clear
    ListBox1.RowSource = "'" & Sheets(.Value).Name & "'!" & Sheets(.Value).Range("A2", Sheets(.Value).Range("H" & Rows.Count).End(3)).Address
  End With
End Sub

Private Sub UserForm_Activate()
  Call LoadListbox
End Sub

Private Sub UserForm_Initialize()
  With ComboBox1
    .AddItem "RPA"
    .AddItem "SS"
    .AddItem "SR"
    .AddItem "RR"
  End With
End Sub
thanks.
 
Last edited:

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top