I'm new to PowerPivot/DAX and I'm having some trouble with a specific issue I'm trying to resolve. I have a series of products across multiple stores and need to ship a certain amount from as few stores as possible.
A table Products contains a list of products and the needed amounts:
Product | Need
0000001 | 7
0000002 | 8
Another table Stores contains the units available by store and I need to calculate how many to send from each store:
Product | Store | Units | Send
0000001 | 00001 | 5 | 5
0000001 | 00002 | 2 | 2
0000001 | 00003 | 1 | 0
0000002 | 00001 | 0 | 0
0000002 | 00002 | 3 | 1
0000002 | 00003 | 3 | 3
0000002 | 00004 | 4 | 4
0000002 | 00005 | 2 | 0
I have thought of adding a couple of columns for the calculation:
Product | Store | Units | Rank | CSum | Send
0000001 | 00001 | 5 | 1 | 5 | 5
0000001 | 00002 | 2 | 2 | 7 | 2
0000001 | 00003 | 1 | 3 | 8 | 0
0000002 | 00001 | 0 | 5 | 12 | 0
0000002 | 00002 | 3 | 3 | 10 | 1
0000002 | 00003 | 3 | 2 | 7 | 3
0000002 | 00004 | 4 | 1 | 4 | 4
0000002 | 00005 | 2 | 4 | 12 | 0
First, I rank the stores within each product by units available, solving ties at random:
Rank := IF(Units>0,RANKX(ALL(Stores,Stores[Product]),Stores[Units]+RAND())
Then, I calculate the cumulative sum:
CSum := CALCULATE(SUM(Stores[Units]),
FILTER(ALL(Stores,Stores[Product]),Stores[Rank]<=MAX(Stores[Rank])))
Finally, I calculate the amount to send out:
Send := IF(Stores[CSum]>RELATED(Products[Need])+Stores[Units],
IF(Stores[CSum]<RELATED(Products[Need]),
Stores[Units],Stores[Units]-(Stores[CSum]-RELATED(Products[Need]))),0)
Needless to say, I'm getting #ERROR. I think the thought process works, but the formulas are wrong. Also, my Stores table has ~2M records with ~20k products, will I have any problem running this?
I thought of another solution -- Using VBA-code. First I want to give the whole code and then describe some problems:
Const maxStores = 16
Public i As Long
Public j As Integer
Public n As Integer
Public m As Long
Public rangeNeeds As Range
Public rangeHave As Range
Public rangeCost As Range
Sub transportation()
Dim Time1, Time2
Dim Txt As String
Txt = "Enter range with "
Set rangeNeeds = Application.InputBox(prompt:=Txt & "Needs", Type:=8)
Set rangeHave = Application.InputBox(prompt:=Txt & "Inventory", Type:=8)
Set rangeCost = Application.InputBox(prompt:=Txt & "Costs", Type:=8)
' find number of Stores
n = rangeCost.Rows.Count
If n <= maxStores Then
' Algorithm #1
'
'
' Step 1
' ------------------------------------------------------------------------
' make array of binary numbers & sort it
Time1 = Timer
' make array of indexes
Dim ArrIndex() As Long
ReDim ArrIndex(1 To n)
For j = 1 To n
ArrIndex(j) = rangeCost(j, 2)
Next j
' make Indexes
minCost = Application.WorksheetFunction.min(ArrIndex)
For j = 1 To n
If minCost = 0 Then
Debug.Print "Can't count Cost = 0"
Exit Sub
End If
ArrIndex(j) = ArrIndex(j) / minCost
Next j
' make array with indexes
' each index represents
' cost of transportanion
Dim Index As Long
Dim ll As Integer
Dim k, Temp
k = 2 ^ n - 1
ll = Len(k) + 1
Dim Arr()
ReDim Arr(1 To k)
For i = 1 To k
' count total index
For j = 1 To n
Index = Index + CInt(Mid(Dec2Bin(i, n), j, 1)) * ArrIndex(j)
Next j
Temp = Index * 10 ^ ll + i
Arr(i) = Temp
Index = 0
Next i
' sort Array
Call Countingsort(Arr)
' end of Step1
' ========================================================================
'
'
' Step2
' ------------------------------------------------------------------------
' Go throug each value and find the answer
Dim ProdNo As Long ' number of products in order
ProdNo = rangeNeeds.Rows.Count
Dim ArrHave() As Long
ReDim ArrHave(1 To ProdNo)
Dim rangeHaveProd As Range
Dim rangeHaveStor As Range
Dim rangeHaveQuan As Range
Set rangeHaveProd = rangeHave.Columns(1)
Set rangeHaveStor = rangeHave.Columns(2)
Set rangeHaveQuan = rangeHave.Columns(3)
For i = 1 To k ' All Binary Numbers
Temp = CInt(Right(Arr(i), ll - 1))
Temp = Dec2Bin(Temp, n)
' try fulfill the order
For j = 1 To n ' All Stores, n -- index of Store
Index = 0
Index = CInt(Mid(Temp, j, 1))
If Index = 1 Then 'If Store is On
For m = 1 To ProdNo ' All Products, m -- index of Product
ArrHave(m) = ArrHave(m) + _
WorksheetFunction.SumIfs( _
rangeHaveQuan, _
rangeHaveProd, rangeNeeds(m, 1), _
rangeHaveStor, rangeCost(j, 1))
Next m
End If
Next j
' Check if Needs meets
Dim CheckNeeds As Boolean
For m = 1 To ProdNo
If ArrHave(m) < rangeNeeds(m, 2) Then
CheckNeeds = False
Exit For
Else
CheckNeeds = True
End If
Next m
If CheckNeeds Then
Debug.Print "Answer is " & Temp
Exit For
Else
ReDim ArrHave(1 To ProdNo)
End If
Next i
' end of Step2
' ========================================================================
'
'
' Step3
' ------------------------------------------------------------------------
' make report
Sheets.Add
Dim Ws As Worksheet
Set Ws = ActiveSheet
With Range("A1")
.Value = "Report"
.Font.Size = 22
.Font.Bold = True
End With
Rows("4:4").Font.Bold = True
With Ws
' Stores table
.Range("G4") = "Store"
.Range("H4") = "Cost"
.Range("I4") = "On"
rangeCost.Copy
.Range("G5").PasteSpecial xlPasteValues
For i = 1 To n
.Range("I" & 4 + i) = Mid(Temp, i, 1)
Next i
' Needs table
.Range("K4") = "Product"
.Range("L4") = "Need"
rangeNeeds.Copy
.Range("K5").PasteSpecial xlPasteValues
' Have table
.Range("A4") = "Product"
.Range("B4") = "Store"
.Range("C4") = "Units"
.Range("D4") = "On"
.Range("E4") = "Send"
rangeHave.Copy
.Range("A5").PasteSpecial xlPasteValues
.Range("D5:D" & 4 + rangeHave.Rows.Count).FormulaR1C1 = _
"=VLOOKUP(RC[-2],C[3]:C[5],3,0)"
Dim QForm As String
QForm = "=IF(RC[-1]=0,0,IF(SUMIFS(C[7],C[6],"
QForm = QForm & "RC[-4])-SUMIFS(R4C5:R[-1]C,R4C1:R[-1]C[-4],"
QForm = QForm & "RC[-4])-RC[-2]>0,RC[-2],IF(SUMIFS(C[7],C[6],RC[-4])"
QForm = QForm & "-SUMIFS(R4C5:R[-1]C,R4C1:R[-1]C[-4],RC[-4])-RC[-2]<0,"
QForm = QForm & "SUMIFS(C[7],C[6],RC[-4])-SUMIFS(R4C5:R[-1]C,"
QForm = QForm & "R4C1:R[-1]C[-4],RC[-4]),RC[-2])))"
.Range("E5:E" & 4 + rangeHave.Rows.Count).FormulaR1C1 = QForm
Range("A2").FormulaR1C1 = "=""Total Cost = ""&INT(SUMIFS(C[7],C[8],1))"
Range("A2").Font.Italic = True
.Calculate
' convert formulas into values
.Range("D5:E" & 4 + rangeHave.Rows.Count) = .Range("D5:E" & 4 + rangeHave.Rows.Count).Value
End With
' end of Step3
' ========================================================================
'
Time2 = Timer
Debug.Print Format(Time2 - Time1, "00.00") & " sec."
Else
MsgBox "Number of stores exceeds Maximum. Need another Algorithm"
End If
End Sub
'Decimal To Binary
' =================
' Source: http://groups.google.ca/group/comp.lang.visual.basic/browse_thread/thread/28affecddaca98b4/979c5e918fad7e63
' Author: Randy Birch (MVP Visual Basic)
' NOTE: You can limit the size of the returned
' answer by specifying the number of bits
Function Dec2Bin(ByVal DecimalIn As Variant, _
Optional NumberOfBits As Variant) As String
Dec2Bin = ""
DecimalIn = Int(CDec(DecimalIn))
Do While DecimalIn <> 0
Dec2Bin = Format$(DecimalIn - 2 * Int(DecimalIn / 2)) & Dec2Bin
DecimalIn = Int(DecimalIn / 2)
Loop
If Not IsMissing(NumberOfBits) Then
If Len(Dec2Bin) > NumberOfBits Then
Dec2Bin = "Error - Number exceeds specified bit size"
Else
Dec2Bin = Right$(String$(NumberOfBits, _
"0") & Dec2Bin, NumberOfBits)
End If
End If
End Function
Sub Countingsort(list)
Dim counts()
Dim i
Dim j
Dim next_index
Dim min, max
Dim min_value As Variant, max_value As Variant
' Allocate the counts array. VBA automatically
' initialises all entries to 0.
min_value = Minimum(list)
max_value = Maximum(list)
min = LBound(list)
max = UBound(list)
ReDim counts(min_value To max_value)
' Count the values.
For i = min To max
counts(list(i)) = counts(list(i)) + 1
Next i
' Write the items back into the list array.
next_index = min
For i = min_value To max_value
For j = 1 To counts(i)
list(next_index) = i
next_index = next_index + 1
Next j
Next i
End Sub
Function Minimum(list)
Dim i As Long
Minimum = list(LBound(list))
For i = LBound(list) To UBound(list)
If list(i) < Minimum Then Minimum = list(i)
Next i
End Function
Function Maximum(list)
Dim i As Long
Maximum = list(LBound(list))
For i = LBound(list) To UBound(list)
If list(i) > Maximum Then Maximum = list(i)
Next i
End Function
First of all want to tell that task is very familiar to Transportation Problem. So I think of possible maths formulas which can find minimal Costs for transportation.
Problem #1. Big data
This solution goes straight through all combinations. It uses binary numbers to decide which store to select. For example, 01101 means try stores 2,3 and 5. This causes much trouble for computer to count each possibility. So I limited number of stores to 16.
Also I tried this code on 1000 products, not 20k. My computer can't solve this with 20k of products. So someone could make my code work faster.
=>
Problem #2. Costs
The third table is costs of transportation from each store. I added it to model:
| Store | Cost |
| 00001 | 5 |
| 00002 | 2 |
| 00003 | 1 |
| 00004 | 1 |
| 00005 | 10 |
So task is to find minimal transportation cost.
=>
Excel version
I used formula SUMIFS in my code. It will not work in Excel 2003.
=>
Conclusion
I believe this gives you some ideas and help someone else to develop the Code.
Related
am trying to resort the data using Code consider the data shape like this :
Empid| 1/01/2019|2/01/2019 | 3/01/2019
-------------------------------------------
1 | A | B | A
2 | B | A | B
3 | B | C | C
4 | A | A | A
and the goal shape like this :
Empid | Date | Shift
---------------------
1 |1/01/2019 | A
1 |2/01/2019 | B
1 |3/01/2019 | A
2 |1/01/2019 | B
2 |2/01/2019 | A
2 |3/01/2019 | B
3 |1/01/2019 | B
3 |2/01/2019 | C
3 |3/01/2019 | C
4 |1/01/2019 | A
4 |2/01/2019 | A
4 |3/01/2019 | A
i used this code and reached to this shape using the code :
Empid | Shift
---------------------
1 |A
1 |B
1 |A
2 |B
2 |A
2 |B
3 |B
3 |C
3 |C
4 |A
4 |A
4 |A
this is the vba code :
Sub TransposeData()
Const FirstDataRow As Long = 2 ' presuming row 1 has headers
Const YearColumn As String = "A" ' change as applicable
Dim Rng As Range
Dim Arr As Variant, Pos As Variant
Dim Rl As Long, Cl As Long
Dim R As Long, C As Long
Dim i As Long
With ActiveSheet
Cl = .UsedRange.Columns.Count - .UsedRange.Column + 1
Rl = .Cells(.Rows.Count, Columns(YearColumn).Column).End(xlUp).Row
Set Rng = Range(.Cells(FirstDataRow, YearColumn), .Cells(Rl, Cl))
End With
Arr = Rng.Value
ReDim Pos(1 To (UBound(Arr) * UBound(Arr, 2)), 1 To 2)
For R = 1 To UBound(Arr)
For C = 2 To UBound(Arr, 2)
i = i + 1
Pos(i, 1) = Arr(R, 1)
Pos(i, 2) = Arr(R, C)
Next C
Next R
R = Rl + 5 ' write 5 rows below existing data
Set Rng = ActiveSheet.Cells(R, YearColumn).Resize(i, 2)
Rng.Value = Pos
End Sub
Use Power Query (aka Get & Transform in Excel 2016+).
Select the first column and UNpivot the other columns.
Rename the resultant Date column (which will be named Attributes by the GUI), and the Shift column (which will be named Value by the GUI).
If you want to do this in VBA, record a macro while running PQ
With a single cell selected in your table, select Get & Transform from Table/Range
Power Query will open. Ensure you have selected the first column. Then, from Transform, select the dropdown next to the Unpivot button. From that dropdown, select unpivot other columns.
After selecting that, you will see that you need to rename columns 2 and 3
After that, select one of the Close options from the File menu, and load the results to either the same sheet or another sheet.
Now you can rerun the query if your data changes.
And, as I wrote above, if you need to do this using VBA, just record a macro while you go through the steps.
I also suggest you search SO for unpivot and you'll get a lot of information.
Array Approach
Option Explicit
Public Sub Rearrange()
Dim t#: t = timer ' stop watch
Dim ws As Worksheet ' worksheet object
Set ws = ThisWorkbook.Worksheets("Sheet3") ' << change to sheet name
Const STARTCOL = "A" ' << change to your needs
' [1] get last row in column A
Dim r&, c& ' used rows/cols (assuming no blanks)
r = ws.Range(STARTCOL & ws.Rows.count).End(xlUp).Row
c = ws.Columns(STARTCOL).End(xlToRight).Column - ws.Columns(STARTCOL).Column
' [2] get values to 1-based 2-dim variant arrays
Dim tmp, tgt
tmp = ws.Range(ws.Cells(1, STARTCOL), ws.Cells(r, c + 1)).Value2
ReDim tgt(1 To c * (UBound(tmp) - 1) + 1, 1 To c) ' resize target array
' [3] rearrange data in target array
Dim i&, ii&, j&
For i = 2 To UBound(tmp)
For j = 2 To UBound(tmp, 2) ' get row data
ii = (i - 1) * c + j - c ' calculate new row index
tgt(ii, 1) = tmp(i, 1) ' get ID
tgt(ii, 2) = tmp(1, j) ' get date
tgt(ii, 3) = tmp(i, j) ' get inditgtidual column data
Next j
Next i
tgt(1, 1) = "EmpId": tgt(1, 2) = "Date": tgt(1, 3) = "Shift" ' get captions
' [4] write target array back wherever you want it to ' << redefine OFFSET
ws.Range("A1").Offset(0, c + 2).Resize(UBound(tgt, 1), UBound(tgt, 2)) = tgt
MsgBox "Time needed: " & Format(timer - t, "0.00") & " seconds."
End Sub
Note
You should format the target range with your preferred date formatting, e.g. "dd/mm/yyyy;#" .
There are 2 worksheets in 1 excel file with the following identical column structure:
BuildIndex | Phase | Module | Duration
The column BuildIndex is used as primary key.
Assume the following example data:
Worksheet 1:
1 | Phase 1 | Module 1 | 5
1 | Phase 2 | Module 1 | 3
1 | Phase 3 | Module 1 | 10
1 | Phase 1 | Module 2 | 6
1 | Phase 2 | Module 2 | 2
1 | Phase 3 | Module 2 | 5
Worksheet 2:
2 | Phase 1 | Module 1 | 3
2 | Phase 2 | Module 1 | 7
2 | Phase 3 | Module 1 | 9
2 | Phase 1 | Module 2 | 2
2 | Phase 2 | Module 2 | 10
2 | Phase 3 | Module 2 | 4
For now I create different pivot tables and diagrams and analyze the differences "by hand" to make decisions like
for build index 1 the module 2 is build X seconds faster than in build index 2
for build index 2 the phase 3 (sum of all modules) is build Y seconds faster than in build index 1
That's what I want to do:
Because there are many phases and the count of modules is increasing continuously, the above procedure takes too much time and I think there's an automatic way to perform analyzes like these.
So, do you have any idea if there's a way to realize my intention? Feel free to provide hints for excel formulas or pivot tables or vba or or or :-)
I solved it using VBA. Never worked before with it, so my code could be improved ;-)
Call AllInOne for phases (any variable used is declared as String):
Option Explicit
Sub ExtractUniquePhasesAndModules()
'--------------------------------------
'| Perform calculations for TEST DATA |
'--------------------------------------
srcSheet = "CompareData"
destSheet = "CompareResults"
destPkColumn = "A"
destColumn = "B"
calculateColumn = "C"
'Phases 1
srcPkCell = "A2"
srcColumn = "B"
sumValuesColumn = "D"
AllInOne srcSheet, srcColumn, destSheet, destColumn, calculateColumn, sumValuesColumn, srcPkCell, destPkColumn
'Phases 2
srcPkCell = "F2"
srcColumn = "G"
sumValuesColumn = "I"
AllInOne srcSheet, srcColumn, destSheet, destColumn, calculateColumn, sumValuesColumn, srcPkCell, destPkColumn
End Sub
And this is the problem solving function:
Private Sub AllInOne(srcSheetName As String, srcColumnName As String, destSheetName As String, _
destColumnName As String, calculateColumnName As String, sumValuesColumnName As String, _
srcPkCellName As String, destPkColumnName As String)
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim srcColumn As Range
Dim destColumn As Range
Dim srcPkCell As Range
Dim destPkColumn As Range
Dim sumValuesColumn As Range
Dim wsf As WorksheetFunction
Set srcSheet = Worksheets(srcSheetName)
Set srcColumn = srcSheet.Range(srcColumnName + ":" + srcColumnName)
Set destSheet = Worksheets(destSheetName)
Set destColumn = destSheet.Range(destColumnName + ":" + destColumnName)
Set srcPkCell = srcSheet.Range(srcPkCellName)
Set destPkColumn = destSheet.Range(destPkColumnName + ":" + destPkColumnName)
Set sumValuesColumn = srcSheet.Range(sumValuesColumnName + ":" + sumValuesColumnName)
Set wsf = WorksheetFunction
'-----------------------
'Copy all unique values|
'-----------------------
destSheet.Select
Dim ctr As Range
'find the first empty cell
For Each ctr In destColumn.Cells
If ctr.Value = "0" Then
'do nothing
ElseIf ctr.Value = Empty Then
Exit For
End If
Next
'start copying
srcColumn.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ctr, Unique:=True
'set destination range to only the new cells
Set destColumn = destSheet.Range(ctr.Address + ":" + destColumnName & destColumn.Count)
Dim cell As Range
Dim calcCell As Range
Dim destPkCell As Range
For Each cell In destColumn.Cells
'end of list reached?
If cell.Value = Empty Then
Exit For
End If
'Fill in primary key
Set destPkCell = destSheet.Range(destPkColumnName & cell.Row)
destPkCell.Value = srcPkCell.Value
'Perform the sum-calculation and show the result
Set calcCell = destSheet.Range(calculateColumnName & cell.Row)
calcCell.Value = wsf.SumProduct(wsf.SumIf(srcColumn, "=" & cell.Value, sumValuesColumn))
Next
End Sub
First it iterates over the destination column to find the first empty cell. This cell is then used as CopyToRange argument in the AdvancedFilter function.
Then it inserts the primary key (BuildIndex in my case) and the result of SumProduct for every row.
The result for phases using the questions data is this:
1 | Phase | 0
1 | Phase 1 | 11
1 | Phase 2 | 5
1 | Phase 3 | 15
2 | Phase | 0
2 | Phase 1 | 5
2 | Phase 2 | 17
2 | Phase 3 | 13
Now I'm able to create diagrams just like I want :-)
Perhaps I'm trying to do too much, but I have a column filled with text. Each cell has an arbitrary number of words, so for example:
| A |
=====|====================|
1 | apple pear yes cat |
2 | apple cat dog |
3 | pear orange |
What I need to do is create a column which is a list of all unique words in that range. So for the above example, the result should be:
| A | B |
=====|====================|========|
1 | apple pear yes cat | apple |
2 | apple cat dog | pear |
3 | pear orange | yes |
4 | | cat |
5 | | dog |
6 | | orange |
In no particular order. Is there any way to do this?
This option uses 1 loop instead of 3, I like to use a dictionary instead or Collection.
Sub Sample()
Dim varValues As Variant
Dim strAllValues As String
Dim i As Long
Dim d As Object
'Create empty Dictionary
Set d = CreateObject("Scripting.Dictionary")
'Create String With all possible Values
strAllValues = Join(Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp))), " ")
'Split All Values by space into array
varValues = Split(strAllValues, " ")
'Fill dictionary with all values (this filters out duplicates)
For i = LBound(varValues) To UBound(varValues)
d(varValues(i)) = 1
Next i
'Write All The values back to your worksheet
Range("B1:B" & d.Count) = Application.Transpose(d.Keys)
End Sub
Give this small macro a try:
Sub dural()
Dim N As Long, U As Long, L As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim st As String
For I = 1 To N
st = st & " " & Cells(I, 1)
Next I
st = Application.WorksheetFunction.Trim(st)
ary = Split(st, " ")
U = UBound(ary)
L = LBound(ary)
Dim c As Collection
Set c = New Collection
On Error Resume Next
For I = L To U
c.Add ary(I), CStr(ary(I))
Next I
For I = 1 To c.Count
Cells(I, 2).Value = c.Item(I)
Next I
End Sub
I have an Excel sheet that looks like this:
3 | latitude | 46.142737
3 | longitude| -57.608968
8 | latitude | 43.142737
8 | longitude| -52.608968
15 | latitude | 41.142737
15 | longitude| -59.608968
I need the end result to look like this:
3 | 46.142737, -57.608968
8 | 43.142737, -52.608968
15 | 41.142737, -59.608968
It can be concatenated based on every other row, or based on the integer value in the first column.
VBA suggestions? Thank you.
Edit: There is no actual "|" in my Excel sheet. The "|" is meant to be a visual cue representing a new column.
You could read the data into an array and then write that to a range
Original Data:
Result:
Code:
Sub Example()
Dim i As Long
Dim x As Long
Dim arry As Variant
ReDim arry(1 To 2, 1 To 1) As Variant
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 1).Row Mod 2 = 1 Then
x = x + 1
ReDim Preserve arry(1 To 2, 1 To x) As Variant
arry(1, x) = Cells(i, 1).Value
arry(2, x) = Cells(i, 3).Value & ", " & Cells(i + 1, 3).Value
End If
Next
arry = WorksheetFunction.Transpose(arry)
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(UBound(arry), UBound(arry, 2))).Value = arry
End Sub
I have the following values in a spreadsheet:
Printer Name | Pages | Copies
HP2300 | 2 | 1
HP2300 | 5 | 1
Laser1 | 2 | 2
Laser1 | 3 | 4
HP2300 | 1 | 1
How can I get the total number of pages printed (pages * copies) on each printer like this:
Printer Name | TotalPages |
HP2300 | 8 |
Laser1 | 16 |
I managed to create a list counting the number of times a printer was used to print:
Sub UniquePrints()
Application.ScreenUpdating = False
Dim Dict As Object
Set Dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = Sheets("Prints").Range("E:E").Value
For Each element In varray
If Dict.exists(element) Then
Dict.Item(element) = Dict.Item(element) + 1
Else
Dict.Add element, 1
End If
Next
Sheets("Stats").Range("D6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.keys)
Sheets("Stats").Range("E6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.items)
Application.ScreenUpdating = True
End Sub
How can I calculate the total pages for each print (row) (pages*copies) and save that in the dictionary instead of just adding 1?
Thank you for your help
Read in the columns E:G rather than just E and use the second dimension of that array to add pages * copies, rather than adding 1.
Sub UniquePrints()
Dim Dict As Object
Dim vaPrinters As Variant
Dim i As Long
Set Dict = CreateObject("scripting.dictionary")
vaPrinters = Sheets("Prints").Range("E2:G6").Value
For i = LBound(vaPrinters, 1) To UBound(vaPrinters, 1)
If Dict.exists(vaPrinters(i, 1)) Then
Dict.Item(vaPrinters(i, 1)) = Dict.Item(vaPrinters(i, 1)) + (vaPrinters(i, 2) * vaPrinters(i, 3))
Else
Dict.Add vaPrinters(i, 1), vaPrinters(i, 2) * vaPrinters(i, 3)
End If
Next i
Sheets("Stats").Range("D6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.keys)
Sheets("Stats").Range("E6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.items)
End Sub
It's possible to use an array formula to get cells populated:
={SUMPRODUCT(IF($A$2:$A$6=$F2;1;0);$B$2:$B$6;$C$2:$C$6)}
The formula is inserted from formula window with Ctrl-Shift-Enter. Curled brackets are inserted by excel, not by a user. The formula can be copied elsewhere.