Hello there
I have put together a code that gives me all possible unique triplets of a series of six numbers.
I would like to have a report that shows the different sources (read, exact location) of all possible triplets.
File attached.
Thanks.
josé
Printable View
Hello there
I have put together a code that gives me all possible unique triplets of a series of six numbers.
I would like to have a report that shows the different sources (read, exact location) of all possible triplets.
File attached.
Thanks.
josé
Assuming by exact location you mean the row number on Plan1 sheet, I've made some changes to your code by commenting out the original line and adding a replacement next to it as well as adding a line or two, but I have some questions below.[vba]Sub B()
Dim LRange As Variant
Dim LRows As Long
Dim LCols As Long
Dim C As New Collection
Dim LItem As Long
Dim LDesc As String
'Dim Counts(100000, 6) As String
Dim Counts(100000, 7) As String
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
On Error Resume Next
'Select sheet where data resides
Sheets("Plan1").Select
'Data range (where draw information resides)
'LRange = Range("A2:H11151")
LRange = Range("A2:H1499") 'just to save time!
LRows = UBound(LRange, 1)
LCols = UBound(LRange, 2)
'Loop through each row in LRange (find pairs)
For i = 1 To LRows
'j and k create the pairs
For j = 1 To LCols - 1
For k = j + 1 To LCols
For l = k + 1 To LCols
For m = l + 1 To LCols
For n = m + 1 To LCols
'Separate pairs with a "." character (smaller number first)
If LRange(i, l) < LRange(i, m) < LRange(i, n) Then
LDesc = LRange(i, l) & "." & LRange(i, m) & "." & LRange(i, n)
Else
LDesc = LRange(i, l) & "." & LRange(i, m) & "." & LRange(i, n)
End If
' myMin = Application.Min(LRange(i, l), LRange(i, m), LRange(i, n))
' myMed = Application.Median(LRange(i, l), LRange(i, m), LRange(i, n))
' myMax = Application.Max(LRange(i, l), LRange(i, m), LRange(i, n))
' LDesc = myMin & "." & myMed & "." & myMax
'Add new item to collection ("on error resume next" is
'required above in this procedure because of this line of code)
C.Add C.Count + 1, LDesc
'Retrieve indexnumber of new item
LItem = C(LDesc)
'Add pair information to new item
If Counts(LItem, 0) = "" Then
Counts(LItem, 0) = LDesc
Counts(LItem, 1) = LRange(i, j)
Counts(LItem, 2) = LRange(i, k)
Counts(LItem, 3) = LRange(i, l)
Counts(LItem, 4) = LRange(i, m)
Counts(LItem, 5) = LRange(i, n)
Counts(LItem, 7) = i + 1 'plus 1 as i is the LRange index, add 1 to get the row on the sheet.Or add LRange.row-1 for a more robust result if LRange doesn't start on row 2.
End If
'Increment stats counter
If Counts(LItem, 6) = "" Then
Counts(LItem, 6) = "1"
Else
Counts(LItem, 6) = CStr(CInt(Counts(LItem, 6)) + 1)
Counts(LItem, 7) = Counts(LItem, 7) & "," & i + 1
End If
Next n
Next m
Next l
Next k
Next j
Next i
'Paste pairs onto sheet called PairStats
Sheets("Sheet1").Select
'Sheets("Plan4").Select
Cells.Select
Selection.Clear
'Cells(1, 1).Resize(C.Count, 7) = Counts
Cells(1, 1).Resize(C.Count + 1, 8) = Counts '+1 needed because I chose only to process A2:H1499 and C is zero-based, so it would have missed the last entry.
'Format headings
Range("A1").FormulaR1C1 = "'N1.N2.N3"
Range("B1").FormulaR1C1 = "'A"
Range("C1").FormulaR1C1 = "'B"
Range("D1").FormulaR1C1 = "'N1"
Range("E1").FormulaR1C1 = "'N2"
Range("F1").FormulaR1C1 = "'N3"
Range("G1").FormulaR1C1 = "'Occurrences"
Range("A1:G1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Columns("A:G").EntireColumn.AutoFit
Range("H1").Select
Range("H1").FormulaR1C1 = "Last Updated on " & Now()
End Sub
[/vba] You'll need to add a Sheet1 to your attached-to-your-message workbook as I wanted to preserve your Plan2 for comparison.
You'll see a new column H on Sheet1 with row numbers, many of them repeated as the combinations come from the same line. Is this what you want? For example, in row 38 of Sheet1 there are 6 occurrences of 39.41.43 but they all come from row 3! Do you really want to count this as 6 occurrences?
Your answer will decide how we remove multiple row numbers in column H
Another dodgy bit is[vba]If LRange(i, l) < LRange(i, m) < LRange(i, n) Then
LDesc = LRange(i, l) & "." & LRange(i, m) & "." & LRange(i, n)
Else
LDesc = LRange(i, l) & "." & LRange(i, m) & "." & LRange(i, n)
End If
[/vba]This does not produce the smaller numbers first for more than one reason; (1) the line after Else is identical to the line before Else and (2) the If part won't identify things in the wrong order. You would need an And or two in there. With your data, the Else part is never executed unless the values being compared are all Empty. The only reason all the results are in the correct order is because they're all in the correct order already on Plan1!
Should you need to address this I've put 4 commented-out lines directly after this IF..End If block to replace it.
Is this the sort of thing you wanted?
I was looking at why so many combos came from the same line and I think you're running through too many combos and repeating some of them for each line. I took just the looping bit of your code, made a few alterations:[VBA]Sub f()
LRows = 1
LCols = 8
For i = 1 To LRows
For j = 1 To LCols - 1
For k = j + 1 To LCols
For l = k + 1 To LCols
For m = l + 1 To LCols
For n = m + 1 To LCols
Debug.Print l, m, n
Next n
Next m
Next l
Next k
Next j
Next i
End Sub
[/VBA]ran it and had a look at the results in the Immediate pane, and there are repeats. Maybe you want something along these lines instead?:[VBA]Sub f2()
LRows = 1
LCols = 8
For i = 1 To LRows
For l = 3 To LCols - 2
For m = l + 1 To LCols - 1
For n = m + 1 To LCols
Debug.Print l, m, n
Next n
Next m
Next l
Next i
End Sub
[/VBA]
or
[VBA]Sub M_snb()
For j = 2 To Sheets("Plan1").Cells(1).CurrentRegion.Rows.Count
c01 = "_" & Sheets("Plan1").Cells(j, 1) & "_" & Sheets("Plan1").Cells(j, 2) & vbLf
Sheets("Plan1").Cells(j, 3).Resize(, 6).Sort Sheets("Plan1").Cells(j, 3), , , , , , , , , , 2
sn = Sheets("Plan1").Cells(j, 3).Resize(, 6)
c00 = sn(1, 1) & "." & sn(1, 2) & "." & sn(1, 3) & vbLf & sn(1, 1) & "." & sn(1, 2) & "." & sn(1, 4) & vbLf & sn(1, 1) & "." & sn(1, 2) & "." & sn(1, 5) & vbLf & sn(1, 1) & "." & sn(1, 2) & "." & sn(1, 6) & vbLf & sn(1, 1) & "." & sn(1, 3) & "." & sn(1, 4) & vbLf & sn(1, 1) & "." & sn(1, 3) & "." & sn(1, 5) & vbLf & sn(1, 1) & "." & sn(1, 3) & "." & sn(1, 6) & vbLf & sn(1, 1) & "." & sn(1, 4) & "." & sn(1, 5) & vbLf & sn(1, 1) & "." & sn(1, 4) & "." & sn(1, 6) & vbLf & sn(1, 1) & "." & sn(1, 5) & "." & sn(1, 6) & vbLf
c00 = c00 & sn(1, 2) & "." & sn(1, 3) & "." & sn(1, 4) & vbLf & sn(1, 2) & "." & sn(1, 3) & "." & sn(1, 5) & vbLf & sn(1, 2) & "." & sn(1, 3) & "." & sn(1, 6) & vbLf & sn(1, 2) & "." & sn(1, 4) & "." & sn(1, 5) & vbLf & sn(1, 2) & "." & sn(1, 4) & "." & sn(1, 6) & vbLf & sn(1, 2) & "." & sn(1, 5) & "." & sn(1, 6) & vbLf & sn(1, 3) & "." & sn(1, 4) & "." & sn(1, 5) & vbLf & sn(1, 3) & "." & sn(1, 4) & "." & sn(1, 6) & vbLf & sn(1, 3) & "." & sn(1, 5) & "." & sn(1, 6) & vbLf & sn(1, 4) & "." & sn(1, 5) & "." & sn(1, 6)
MsgBox Replace(c00, vbLf, c01) & c01
Next
End Sub[/VBA]
P45cal
thanks for the tips and fixes. Your suggestion works and I can clean the row repetitions references.
What I was actually trying to do is to generate a report (such as in a pivot table) for each repetition with the unique reference number (Column A Plan1) and date in a different sheet. So, let's say for the triplets 4.5.33 (row 2 of Plan1), if click on the triplet it would generate a report in Sheet2 with all occurrences for this triplet with the dates and reference number.
Thanks a lot
try this which add a new sheet, reates a source table for a pivot table, then creates a pivot table along side, double click on any count and a new drill-down sheet will be made. You can sort the count Largest to Smallest too.[VBA]Sub B3()
Dim PTSourceRange As Range
Dim LRange As Variant
Dim LRows As Long
Dim LCols As Long
Dim LDesc As String
Dim i As Long, l As Long, m As Long, n As Long
Dim Counts()
Set PTDataSourceSht = Sheets.Add
With Sheets("Plan1")
'Data range (where draw information resides)
'LRange = Range("A2:H11151")
LRange = .Range("A2:H1499")
LRows = UBound(LRange, 1)
LCols = UBound(LRange, 2)
ReDim Counts(1 To LRows * 20, 1 To 3)
h = 1
For i = 1 To LRows
For l = 3 To LCols - 2
For m = l + 1 To LCols - 1
For n = m + 1 To LCols
myMin = Application.Min(LRange(i, l), LRange(i, m), LRange(i, n))
myMed = Application.Median(LRange(i, l), LRange(i, m), LRange(i, n))
myMax = Application.Max(LRange(i, l), LRange(i, m), LRange(i, n))
LDesc = myMin & "." & myMed & "." & myMax
Counts(h, 1) = LDesc
Counts(h, 2) = LRange(i, 1)
Counts(h, 3) = LRange(i, 2)
h = h + 1
Next n
Next m
Next l
Next i
End With
With PTDataSourceSht
Set PTSourceRange = .Range("a2").Resize(UBound(Counts), 3)
PTSourceRange = Counts
.Range("A1").Value = "N1.N2.N3"
.Range("B1").Value = "A"
.Range("C1").Value = "B"
With .Range("A1:C1")
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
End With
Set PTSourceRange = .Range("a1").Resize(UBound(Counts) + 1, 3)
Set PT = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PTSourceRange, Version:=xlPivotTableVersion14).CreatePivotTable(TableDestination:=.Range(" F4"), DefaultVersion:=xlPivotTableVersion14)
PT.PivotFields("N1.N2.N3").Orientation = xlRowField
PT.AddDataField PT.PivotFields("A"), "Count", xlCount
.Range("D1").Value = "Last Updated on " & Now()
.Columns("A:D").EntireColumn.AutoFit
End With
End Sub[/VBA]
p45cal
this is great.
Thank you for all your good help.