Попарное сравнение данных в столбцах в массиве

[lemonplasticine]

Добрый день, уважаемые гуру экселя! обращаюсь за помощью! которую неделю ломаю голову над следующей задачей.

имеется массив данных - данные по производству 1143 товаров регионами страны. нужно найти значения, которые бы соответствовали числу регионов, производящих каждую пару товаров. производство зашифровано дамми - 1-товар производится, 0 - не производится. Т.е., сколько регионов одновременно производит товар1 и товар2, товар 1 и товар 3, товар 2 и товар3 и т.д. Всего получается, кажется, (n*(n-1))/2 комбинаций.
прилагаю файл.

в экселе я новичок, но буду терпеливо разбираться со всем, что напишете!
огромное спасибо! горит дипломная работа, не знаю, что и делать ((((((

[alex77755]

Ну у меня получилось 245215 таких уникальных совпадений
Сейчас думаю как это всё показать

[lemonplasticine]

заранее большое спасибо жду!
а можно будет посмотреть методику решения такой задачи?

[alex77755]

Ну я только такое придумал. Пробовал стандартными фильтрами - что-то ещё дольше получается. По идее запросами должно получиться быстрее, но я с ними мала дружу.
Вывод на лист не стал делать.
Результат в массиве MZ

Sub KOMB()
Dim M()
Dim LR, LC
Dim R, C, L, K
Dim PARA
Dim Dict As Object
Dim MK()
Dim MZ()
Set Dict = CreateObject("Scripting.Dictionary")
Sheets("Лист1").Select
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
M = Range(Cells(1, 1), Cells(LR, LC)).Value
For C = 1 To LC - 1
    For L = C + 1 To LC
        For K = 2 To LR
            If M(K, C) = 1 Then
                If M(K, L) = 1 Then 'пара
                    PARA = M(1, C) & "+" & M(1, L)
'                   Debug.Print C, K, L, M(1, C), M(1, L), M(K, 1)
                    If Dict.Exists(PARA) Then
                        Dict.Item(PARA) = Dict.Item(PARA) & ";" & M(K, 1)
                    Else
                        Dict.Add PARA, PARA & "|" & M(K, 1)
                    End If
                    DoEvents
                End If
            End If
        Next K
    Next L
Next C
'Sheets("Лист2").Select
'Sheets("Лист2").Cells.ClearContents
'MK = Dict.keys
MZ = Dict.items

'Sheets("Лист2").Range("A1").Resize(Dict.Count) = Application.Transpose(Dict.keys)
'Sheets("Лист2").Range("B1").Resize(Dict.Count) = Application.Transpose(Dict.items)

End Sub

[IgorGO]

вижу 77*n*(n-1)/2 вариантов.
вот это

Function Twice() As Long
  Dim N As Long, c As Long, r As Long
  N = 0
  For c = 3 To 1144
    For r = 2 To 78
      If Cells(r, c) = 1 Then N = N + WorksheetFunction.Sum(Range(Cells(r, 2), Cells(r, c - 1)))
    Next
  Next
  Twice = N
End Function

сосчитало 1 115 744 пар в Вашем файле

[alex77755]

А я пары не считал. Дабавил подсчёт - точно.
А вот уточнённое значение уникальных пар: 410637(нашёл у себя ошибку)
Остальные повторы по регионам

[lemonplasticine]

спасибо большое! я правильно поняла, что у alex77755 считает только совпдаения по 1, а у IgorGO вообще все совпадения и нули тоже?

и еще, подскажите, пожалуйста, почему макрос может не запускаться? нажимаю кнопку запустить, процессор начинает грузиться, потом перестает,но ничего не происходит

[alex77755]

Запусти пошагово

[alex77755]

а у IgorGO вообще все совпадения и нули тоже

а у IgorGO считает все пары, но не сортирует по регионам.
Общее количество пар у меня такое же

[lemonplasticine]

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