Find number of possible combinations in a list - vba

Hi

It looks like a case of not being able to see the wood for the trees. You have to much data so you need to simplify things.

I am working on a couple of ideas for you.

Are you limited to Excel only? "Market basket analysis" is a common data mining task, and there are many pre-programmed utilities available. At one time (Excel 2010, I believe) Excel had a "shopping basket analysis" tool (through Power BI, I think: https://docs.microsoft.com/en-us/pre...ql-server-2017 and https://techcommunity.microsoft.com/...016/m-p/130589 ), but MSFT did not keep the tool functional in later versions of Excel. Power-BI appears to still be able to do market basket analysis (https://finance-bi.com/power-bi-basket-analysis/ ), just not necessarily integrated with Excel. Of course, if you are allowed to look beyond MSFT products, there are many data mining tools that can do market basket analysis (your favorite internet search engine should be able to help you find them).

If you must program your own algorithm in Excel, perhaps this tutorial will be useful: https://people.revoledu.com/kardi/tu...sket/index.htm

Try running this macro to reduce your data.

Sub Macro2()

'Find Your Last Row
LR = Cells(Rows.Count, 1).End(xlUp).Row

'Sort your Data by Order Number and then by Item
    ActiveWorkbook.Worksheets("BEFORE").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("BEFORE").Sort.SortFields.Add2 Key:=Range( _
        "A2:A" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("BEFORE").Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("BEFORE").Sort
        .SetRange Range("A1:B5" & LR)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'Enter a formula in Column C to find the maximum number of items on an order
    
With Range("C2:C" & LR)
.FormulaR1C1 = "=IF(RC[-2]<>R[-1]C[-2],1,R[-1]C+1)"
MaxItems = Application.Max(.Value)
End With

'Select the number of cells to put the formula to transpose your items into a horizontal line
DataRange = Range("C2", Cells(LR, MaxItems + 2)).Address

'Enter the formula to tanspose your data
With Range(DataRange)
.Formula2R1C1 = _
        "=IF(OR(RC1=R[-1]C1,INDEX(RC1:R20000C1,COLUMN()-2,1)<>RC1),"""",INDEX(RC2:R20000C2,COLUMN()-2,1))"
.Value = .Value
End With

Columns(2).Delete
Rows(1).Delete
With Range("A1:A" & LR)
.FormulaR1C1 = "=TEXTJOIN("", "",TRUE,RC[1]:RC[" & MaxItems + 2 & "])"
.Value = .Value
End With

    Columns("B:" & Split(Cells(1, MaxItems + 2).Address, "$")(1)).Delete
    
With Columns("A:A")
    .Columns.AutoFit

        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
End With

    ActiveWorkbook.Worksheets("BEFORE").Sort.SortFields.Add2 Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("BEFORE").Sort
        .SetRange Range("A1:A" & LR)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub