How to compare two (pivot) tables data on (different) worksheets? - excel

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 :-)

Related

paste values if cells match

In the previous post you guys helped me to find out a solution in order to copy-paste cells.
By now I've got a slight different problem.
Here is it; I've got 2 different sheets;
worksheets("Food")
Worksheets("Numbers")
In worksheets("Food"), I've got the following board;
| Fruits | Vegetables |
| -------- | --------------|
| Banana | Carrots |
| Peach | Spinachs |
| Pineapple | Cauliflowers |
In worksheets("Numbers"), I've got this;
| Fruits | Numbers |
| -------- | --------- |
| Banana | 9 |
| Apple | 2 |
| Orange | 3 |
| Peach | 7 |
| Pineapple | 5 |
I'd like to search for each fruits from worksheets("Food") if they do exist in worksheets("Numbers"). If yes, then automatically insert a new column in worksheets("Food") between column Fruits and Vegetables named "Numbers".
After, picked up numbers beside each found fruits in worksheets("Numbers") and paste it in worksheets("Food") beside the matching fruit in the new created column.
Like this;
| Fruits |*Numbers* |Vegetables
| -------- |-------------- |------------
| Banana |**9** |Carrots
| Peach |**7** |Spinachs
| Pineapple |**5** |Cauliflowers
I've been trying to run a code doing this process but as I run it nothing happens ( no error occurs neither)...
Here is it;
Sub Add_Fruits_Numbers()
Dim lastlineFood As Long
Dim lastlineRef As Long
Dim j, i, compteur As Integer
Dim x As Long, rng As range
lastlineRef = Worksheets("Numbers").range("A" & rows.Count).End(xlUp).row
For j = 1 To lastlineRef
lastlineFood = Worksheets("Food").range("A" & rows.Count).End(xlUp).row
For i = 1 To lastlineFood
If range("A" & i).Value = Worksheets("Numbers").range("A" & j).Value Then
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
For Each cell In rng
If cell.Value = "Fruits" Then
cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight)
End If
Next cell
Worksheets("Food").range("A" & i).Offset(, 1).Value = Worksheets("Numbers").range("A" & j).Offset(, 1)
End If
Next i
Next j
End Sub
I'd heavily appreciate your help once again, thank you !
Your code has some problems. It should raise an error on the line
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
if the active sheet is not "Numbers". range("A1").End(xlToRight) refers the active sheet. The correct code should be:
Set rng = Worksheets("Numbers").range("A1", Worksheets("Numbers").range("A1").End(xlToRight))
Then, your code inserts a column in the "Numbers" sheet.
You should use Range("B" & i).EntireColumn.Insert instead of cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight). cell belongs to the range in "Numbers" sheet.
The code logic is wrong. The above sequence must be run only once. Otherwise it will insert a column for each match. "Fruits" will be there of each iteration.
Then everything is messed up and debugging more has no sense, no offence...
It is easier to show you a simpler/faster code, doing what (I understood) you want.
Please, try the next code:
Sub bringFruitsNo()
Dim shF As Worksheet, shN As Worksheet, lastRF As Long, lastRN As Long
Dim arrF, rngN As Range, mtch, i As Long, boolOK
Set shF = Sheets("Food")
Set shN = Sheets("Numbers")
lastRF = shF.Range("A" & shF.rows.count).End(xlUp).row 'last row
lastRN = shN.Range("A" & shN.rows.count).End(xlUp).row 'last row
If shF.Range("B1").value = "Numbers" Then boolOK = True 'check if the column has already been inserted in a previous run
arrF = shF.Range("A2:A" & lastRF).value 'put the first column in an array (for a faster iteration)
Set rngN = shN.Range("A2:A" & lastRN) 'set the range where to search for the fruit existence
For i = 1 To UBound(arrF) 'iterate between the array elements:
mtch = Application.match(arrF(i, 1), rngN, 0) 'if the fruit has bee found:
If IsNumeric(mtch) Then
'insert the new necessary column and mark the inserting event changing the boolean variable value
If Not boolOK Then shF.Range("B1").EntireColumn.Insert: shF.Range("B1").value = "Numbers": boolOK = True
shF.Range("B" & i + 1) = shN.Range("B" & mtch + 1).value 'Place the number in the new column
End If
Next i
End Sub
But, I think you maybe will need to use this code after the column has been inserted, and the code is checking if between "Fruits" and "Vegetables" a column named "Numbers" exists...
If not necessary, and always the code must insert a column between the first and the third column, that line can be deleted.

Macro stops prematurely

Macro to keep on going to the next cell till the value doesn't match and for all the similar values, subtract the values from the bottom most row
Essentially my data is like this (There is only one buy for each name and it is the bottom most cell)
Name | Transaction.Type | Amount | Remaining (what macro needs to do)
Name1 | Sell | 5 | 15 (20-5)
Name1 | Sell | 10 | 10 (20-10)
Name1 | Sell | 15 | 5 (20-15)
Name1 | Buy | 20 |
Name2 | Sell | 25 | 5
Name2 | Buy | 30 |
So far my macro looks like
Dim sline As Integer
Dim eline As Integer
Dim rng As Range
Dim lastrow(1 To 3) As Long
Application.DisplayAlerts = False
With Worksheets("Testing Data 2")
lastrow(1) = .Cells(Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To 4151
If Worksheets("Testing Data 2").Range("A" & i) <> Worksheets("Testing Data 2").Range("A" & i).Offset(1, 0) Then
eline = i
Worksheets("Testing Data 2").Range(":C" & eline)
'struggling to go from here
End If
Next i
Application.DisplayAlerts = True
You can do this without VBA with the understanding that each Name only has one instnace of Buy
=SUMIFS(C:C,A:A,A3,B:B,"Buy")-C2 'Drag down as needed

Show data from a spreadsheet according to the selected data in another spreadsheet

Probably this question is very rookie, but not really used to play a lot with Excel, anyway here I go.
I have 2 spreadsheets: A and B
In the spreadsheet "A" have the following info:
+----------+--------+-------+------+
| DATE | CODE | CORRL | CAPA |
+----------+--------+-------+------+
| 01/03/17 | 110104 | 5 | 28 |
| 01/03/17 | 110104 | 7 | 30 |
| 01/03/17 | 810107 | 5 | 30 |
+----------+--------+-------+------+
and in the spreadsheet "B" the following info:
+----------+--------+-------+--------+
| DATE | CODE | CORRL | SN |
+----------+--------+-------+--------+
| 01/03/17 | 110104 | 5 | 182694 |
| 01/03/17 | 110104 | 5 | 571394 |
| 01/03/17 | 110104 | 7 | 298435 |
| 01/03/17 | 110104 | 7 | 205785 |
| 01/03/17 | 810107 | 5 | 234519 |
| 01/03/17 | 810107 | 5 | 229787 |
+----------+--------+-------+--------+
So what I need is when I move through the records of the spreadsheet "A" only the records with the same value of DATE, CODE and CORRL in the spreadsheet "B" are shown
Example:
If I'm positioned in the 1st row of the spreadsheet "A" in the spreadsheet "B" only the first 2 records must be shown, that is:
+-----------+---------+--------+--------+
| DATE | CODE | CORRL | SN |
+-----------+---------+--------+--------+
| 01/03/17 | 110104 | 5 | 182694 |
| 01/03/17 | 110104 | 5 | 571394 |
+-----------+---------+--------+--------+
and so on
Thanks
I have to say, this is one of the more different requests that I've seen for Excel functionality.
I think I have something for you.
Firstly, if you're not familiar with the VBA editor then you can access it by pressing Alt + F11. Another way to access it is from the Developer tab in your ribbon, which is hidden by default. To unhide it, change the ribbon to include it.
From there you can get to the VBA editor as well as run macros.
From within there, add the following code ...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lngRow As Long, lngCol As Long, strDate As String, strCode As String, strCorrl As String
Dim strKey As String, strSlaveKey As String, i As Long
If objSlaveSheet Is Nothing Then Exit Sub
objSlaveSheet.Rows.EntireRow.Hidden = True
objSlaveSheet.Rows(1).Hidden = False
If Target.Cells(1, 1).Row > 1 Then
With Target.Worksheet
strDate = .Cells(Target.Row, 1)
strCode = .Cells(Target.Row, 2)
strCorrl = .Cells(Target.Row, 3)
strKey = strDate & "_" & strCode & "_" & strCorrl
End With
' Now loop through all of the cells in the slave workbook.
' Start at the second row because the first has a header.
With objSlaveSheet
For lngRow = 2 To .Rows.Count
strSlaveKey = ""
For i = 1 To 3
strSlaveKey = strSlaveKey & "_" & .Cells(lngRow, i)
Next
strSlaveKey = Mid(strSlaveKey, 2)
If strSlaveKey = "__" Then Exit For
If strSlaveKey = strKey Then
.Rows(lngRow).Hidden = False
End If
Next
.Activate
.Cells(1, 1).Select
End With
End If
End Sub
... into the worksheet where you want to trigger the selection from, this is your worksheet A.
Also in workbook A, create a new Module in the VBA editor and paste the following code ...
Public objSlave As Workbook
Public objSlaveSheet As Worksheet
Public Sub SelectSlaveBook()
Dim objDlg As FileDialog, strFile As String, strSlaveSheetName As String
strSlaveSheetName = "Sheet1"
Set objDlg = Application.FileDialog(msoFileDialogOpen)
objDlg.Show
If objDlg.SelectedItems.Count > 0 Then
strFile = objDlg.SelectedItems(1)
Set objSlave = Application.Workbooks.Open(strFile, False, True)
Set objSlaveSheet = objSlave.Worksheets(strSlaveSheetName)
ThisWorkbook.Activate
End If
End Sub
... before moving on, make sure you change the value of strSlaveSheetName to be the name of the sheet where your data is in your "Slave" workbook (B).
Finally in worksheet A, add the following code into the ThisWorkbook object ...
Private Sub Workbook_Open()
SelectSlaveBook
End Sub
... now close the master workbook (in your case, workbook A) and open it again.
You will be prompted for the location of the "Slave" workbook (workbook B).
Once you've given that location, select what you want to select and all things held constant, it should work for you.
Of course, if it needs tweaks to suit your exact requirement, that's always possible.
I hope it works for you.

resorting table using array

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;#" .

Capping a cumulative sum by rank

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.

Resources