Найти наиболее распространенные комбинации чисел в Excel

Question

Я новичок в этом форуме, но после просмотра нескольких сообщений, похожих на то, что я ищу, я решил опубликовать одно самостоятельно, поскольку уже опубликованные сообщения, очевидно, не работают для моей проблемы.Однако, если есть опубликованный код, который может работать для моего случая, пожалуйста, дайте мне знать, что я должен изменить, чтобы заставить его работать и извинения, я новичок в этом ..

У меня есть лист снаборы чисел в диапазоне от 1 до 90, в каждой строке по 5 случайных чисел, например: 23 34 56 02 10

То, что я хотел бы найти в Excel, - это наиболее распространенные комбинации из 3 или 4 чиселв нескольких строках у меня есть пример:

23 34 56 02 10

10 52 34 23 02

56 02 10 22 33

42 05 08 76 51

23 56 02 10 15

88 86 56 10 03

и т. Д., Что означает наиболее распространенную комбинацию из 4 чисел в этом короткомНапример, 23 56 02 10

Исходя из этого, конечно, данные, которые я должен анализировать, всегда продолжаются с наборами по пять, но достигают более 1000 строк.

Существует ли код, который я могу реализовать в VBA, или формула, которую я могу использовать, чтобы выяснить, как часто одни и те же числа появляются в каждой строке?

Я сделал это независимо с числами, используя гистограмму, но теперь я хотел бы видеть количество комбинаций, где сходные числа появляются вместе.

Заранее спасибо за помощь.Я немного новичок, поэтому, если бы вы могли объяснить это шаг за шагом, то я был бы очень признателен.

Answer 1

Option Explicit

Sub Delete_Columns_G_to_Q()
    Range("G:Q").Delete
    ActiveWorkbook.Save
End Sub

Sub Main_without_Sort()

    'uncomment if you want to write sample data
    'Call SampleData

    CreateNumbers
    CopyResults
    CreatePivot

End Sub

Sub Main_including_Sort()

    'uncomment if you want to write sample data
    'Call SampleData

    SortEverySingleRow_by_Column
    CreateNumbers
    CopyResults
    CreatePivot

End Sub

Sub SampleData()

Dim a(10) As String
Dim b() As String
Dim numParts As Integer
Dim iCt As Integer
Dim jCt As Integer

a(1) = "23 34 56 02 10"
a(2) = "10 52 34 23 02"
a(3) = "56 02 10 22 33"
a(4) = "42 05 08 76 51"
a(5) = "23 56 02 10 15"
a(6) = "88 86 56 10 03"

With Range("A:F")
    .HorizontalAlignment = xlCenter
End With

For iCt = 1 To 6
    b = Split(a(iCt), " ")
    numParts = UBound(b) + 1
    Range(Cells(iCt, 1), Cells(iCt, numParts)).Value = b
    For jCt = 1 To 5
        Cells(iCt, jCt).Value = Cells(iCt, jCt).Value
        Debug.Print Cells(iCt, jCt).Address
    Next jCt
Next iCt
End Sub

Sub SortEverySingleRow_by_Column()
Dim iCt As Integer
Dim sortRange As Range

For iCt = 1 To 6
    Set sortRange = Range("A1:E1")
    If iCt > 1 Then
        Set sortRange = Range("A1:E1").Offset(iCt - 1, 0)
    End If
    'Debug.Print sortRange.Address
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=sortRange, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange sortRange
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
Next iCt

End Sub

Sub CreateNumbers()

Dim iCt As Integer
Dim jCt As Integer

With Columns("G:M")
    .ColumnWidth = 13
    .HorizontalAlignment = xlCenter
End With

For iCt = 0 To 5
    Range("G1").Offset(iCt, 0).Select
    Call CreateFormulas
Next iCt

End Sub


Sub CreateFormulas()
    ActiveCell.FormulaR1C1 = _
        "=TEXT(RC[-6],""00"")& "" "" & TEXT(RC[-5],""00"")& "" "" & TEXT(RC[-4],""00"")& "" "" & TEXT(RC[-3],""00"")"
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(RC[-7],""00"")& "" "" & TEXT(RC[-6],""00"")& "" "" & TEXT(RC[-5],""00"")& "" "" & TEXT(RC[-3],""00"")"
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(RC[-8],""00"")& "" "" & TEXT(RC[-7],""00"")& "" "" & TEXT(RC[-5],""00"")& "" "" & TEXT(RC[-4],""00"")"
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(RC[-9],""00"")& "" "" & TEXT(RC[-7],""00"")& "" "" & TEXT(RC[-6],""00"")& "" "" & TEXT(RC[-5],""00"")"
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(RC[-9],""00"")& "" "" & TEXT(RC[-8],""00"")& "" "" & TEXT(RC[-7],""00"")& "" "" & TEXT(RC[-6],""00"")"
End Sub

Sub CopyResults()
Dim lastRow As Long
Dim colCt As Integer

    lastRow = Range("G1").SpecialCells(xlCellTypeLastCell).Row
    'Debug.Print lastRow

    Range("M1").Value = "RESULTS"

    For colCt = 1 To 5
        Range("F1:F" & lastRow).Offset(0, colCt).Copy
        'Debug.Print Range("F1:F" & lastRow).Offset(0, colCt).Address
        Range("M2").Offset(lastRow * (colCt - 1), 0).PasteSpecial xlPasteValues
        'Range("M2").Offset(lastRow * (colCt - 1), 1).Value = "colCt = " & colCt
        Application.CutCopyMode = False
    Next colCt

    Range("N1").Select
End Sub

Sub CreatePivot()

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        Range("M1").CurrentRegion, Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:="Sheet1!R1C15", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion15
    Sheets("Sheet1").Select
    Cells(1, 15).Select
    Range("P5").Select
    With ActiveSheet.PivotTables("PivotTable1")
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("RESULTS")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("RESULTS"), "Sum of RESULTS", xlSum
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of RESULTS")
        .Caption = "Count of RESULTS"
        .Function = xlCount
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("RESULTS").AutoSort _
        xlDescending, "Count of RESULTS", ActiveSheet.PivotTables("PivotTable1"). _
        PivotColumnAxis.PivotLines(1), 1
    Range("G1").Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("RESULTS")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveWorkbook.ShowPivotTableFieldList = False
End Sub

Answer 2

Результаты будут вставлены в лист 2 отсортирован.Причина выбора отображения всех значений заключается в том, что во многих случаях у вас есть числа с одинаковым количеством повторений.Наконец, я думаю, что вы делаете ошибку, потому что четыре числа с большим количеством повторений - это 23, 34, 56, 2.

Попробуйте:

Option Explicit

Sub test()

    Dim LastRowS1A As Long, LastRowS2A As Long, Times As Long, i As Long, y As Long
    Dim str1 As String, str2 As String

    LastRowS1A = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row

    For i = 1 To LastRowS1A

        str1 = Sheet1.Range("A" & i).Value & " " & Sheet1.Range("B" & i).Value & " " & Sheet1.Range("C" & i).Value & " " & Sheet1.Range("D" & i).Value & " " & Sheet1.Range("E" & i).Value

        LastRowS2A = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row

        If Application.WorksheetFunction.CountIf(Sheet2.Range("A1:A" & LastRowS2A), str1) = 0 Then

            Times = 1

            For y = i + 1 To LastRowS1A

                str2 = Sheet1.Range("A" & y).Value & " " & Sheet1.Range("B" & y).Value & " " & Sheet1.Range("C" & y).Value & " " & Sheet1.Range("D" & y).Value & " " & Sheet1.Range("E" & y).Value

                If str1 = str2 Then
                    Times = Times + 1
                End If

            Next y

            Sheet2.Range("A" & LastRowS2A + 1).Value = str1
            Sheet2.Range("B" & LastRowS2A + 1).Value = Times

        End If

    Next i


    LastRowS2A = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row

    Sheet2.Range("A2:B" & LastRowS2A).Sort Key1:=Sheet2.Range("B1"), Order1:=xlDescending, Header:=xlNo

End Sub

Лист 1:

Лист 2 :