Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/получить таблицу с комбинациями и количеством повторов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » получить таблицу с комбинациями и количеством повторов
получить таблицу с комбинациями и количеством повторов
YOUGIN Дата: Среда, 14.01.2026, 14:49 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Приветствую.
Таблица с числами проверяется на все повторы комбинаций построчно функцией =СЧЁТЕСЛИМН.
Необходимо получить таблицу с комбинациями и количеством повторов(таблица справа в примере).
С помощью чего можно это сделать? До этого с excelем не работал.
К сообщению приложен файл: knigaexem1.xlsx (11.0 Kb)
 
Ответить
СообщениеПриветствую.
Таблица с числами проверяется на все повторы комбинаций построчно функцией =СЧЁТЕСЛИМН.
Необходимо получить таблицу с комбинациями и количеством повторов(таблица справа в примере).
С помощью чего можно это сделать? До этого с excelем не работал.
Автор - YOUGIN
Дата добавления - 14.01.2026 в 14:49
Gustav Дата: Среда, 14.01.2026, 16:42 | Сообщение № 2
Группа: Админы
Ранг: Участник клуба
Сообщений: 2875
Репутация: 1216 ±
Замечаний: ±

начинал с Excel 4.0, видел 2.1
Цитата YOUGIN, 14.01.2026 в 14:49, в сообщении № 1 ()
С помощью чего можно это сделать?


Скорее всего, с помощью макроса. Это такая программа на языке программирования VBA, встроенном в Excel. Формулами тут, если что-то и получится, будет очень громоздко.

Вердикт: макрос писать надо!

МОИ: Ник, Tip box: 41001663842605
 
Ответить
Сообщение
Цитата YOUGIN, 14.01.2026 в 14:49, в сообщении № 1 ()
С помощью чего можно это сделать?


Скорее всего, с помощью макроса. Это такая программа на языке программирования VBA, встроенном в Excel. Формулами тут, если что-то и получится, будет очень громоздко.

Вердикт: макрос писать надо!
Автор - Gustav
Дата добавления - 14.01.2026 в 16:42
NikitaDvorets Дата: Среда, 14.01.2026, 17:25 | Сообщение № 3
Группа: Авторы
Ранг: Ветеран
Сообщений: 632
Репутация: 148 ±
Замечаний: 0% ±

Excel 2019
Добрый день!
Цитата
Вердикт: макрос писать надо!


Именно. Вариант с UDF (User Defined Function)
К сообщению приложен файл: pe_chislo_kombinacij_states_14.xlsm (26.1 Kb)
 
Ответить
СообщениеДобрый день!
Цитата
Вердикт: макрос писать надо!


Именно. Вариант с UDF (User Defined Function)
Автор - NikitaDvorets
Дата добавления - 14.01.2026 в 17:25
YOUGIN Дата: Среда, 14.01.2026, 20:21 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Цитата NikitaDvorets, 14.01.2026 в 17:25, в сообщении № 3 ()
Именно. Вариант с UDF (User Defined Function)

Спасибо за информацию.С этого начну.Вообще основной массив более 5000 строк, и сами комбинации неизвестны То есть необходимо узнать самые встречающиеся комбинации state1[2.3.4].В этом и сложность.
 
Ответить
Сообщение
Цитата NikitaDvorets, 14.01.2026 в 17:25, в сообщении № 3 ()
Именно. Вариант с UDF (User Defined Function)

Спасибо за информацию.С этого начну.Вообще основной массив более 5000 строк, и сами комбинации неизвестны То есть необходимо узнать самые встречающиеся комбинации state1[2.3.4].В этом и сложность.
Автор - YOUGIN
Дата добавления - 14.01.2026 в 20:21
Gustav Дата: Среда, 14.01.2026, 21:15 | Сообщение № 5
Группа: Админы
Ранг: Участник клуба
Сообщений: 2875
Репутация: 1216 ±
Замечаний: ±

начинал с Excel 4.0, видел 2.1
Накидал свой макрос, не особо оптимизируясь - пусть будет в качестве первого приближения. В колонках W:AA повторяет картину, приведенную в колонках P:T
[vba]
Код
Sub io()
    Dim rngSource   As Range
    Dim rngTarget   As Range
    Dim cell        As Range
    Dim i           As Long
    Dim ncnt        As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'A&B
    For Each cell In Range("G2:G15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&C
    For Each cell In Range("I2:I15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(3) = rngSource.Cells(cell.row, 3)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D
    For Each cell In Range("K2:K15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D&B
    For Each cell In Range("M2:M15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub
[/vba]

МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеНакидал свой макрос, не особо оптимизируясь - пусть будет в качестве первого приближения. В колонках W:AA повторяет картину, приведенную в колонках P:T
[vba]
Код
Sub io()
    Dim rngSource   As Range
    Dim rngTarget   As Range
    Dim cell        As Range
    Dim i           As Long
    Dim ncnt        As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'A&B
    For Each cell In Range("G2:G15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&C
    For Each cell In Range("I2:I15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(3) = rngSource.Cells(cell.row, 3)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D
    For Each cell In Range("K2:K15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D&B
    For Each cell In Range("M2:M15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub
[/vba]
Автор - Gustav
Дата добавления - 14.01.2026 в 21:15
Gustav Дата: Среда, 14.01.2026, 21:37 | Сообщение № 6
Группа: Админы
Ранг: Участник клуба
Сообщений: 2875
Репутация: 1216 ±
Замечаний: ±

начинал с Excel 4.0, видел 2.1
Немного оптимизировался - вынес 4 раза повторяющуюся конструкцию чтения комбинаций в отдельную подпрограмму:
[vba]
Код
Option Explicit

Dim rngSource   As Range
Dim rngTarget   As Range

'подпрограмма обработки комбинаций типа A&B, A&C и т.д.
Sub doCombi(strRangeAddr, arrCols)

    Dim cell    As Range
    Dim col     As Variant 'Long
    
    For Each cell In Range(strRangeAddr)
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            For Each col In arrCols
                rngTarget.Cells(col) = rngSource.Cells(cell.row, col)
            Next col
            rngTarget.Cells(5) = cell.Value
        End If
    Next

End Sub

'ГЛАВНАЯ ПРОГРАММА, которую надо запускать
Sub io_v2()

    Dim i       As Long
    Dim ncnt    As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'читаем повторяющиеся комбинации
    'A&B
    doCombi "G2:G15", Array(1, 2)
    
    'A&C
    doCombi "I2:I15", Array(1, 3)
    
    'A&D
    doCombi "K2:K15", Array(1, 4)
    
    'A&D&B
    doCombi "M2:M15", Array(1, 2, 4)
       
       
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub
[/vba]

YOUGIN, сможете сами загрузить код в свой файл и запустить? Или мне подготовить рабочий файл?

МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеНемного оптимизировался - вынес 4 раза повторяющуюся конструкцию чтения комбинаций в отдельную подпрограмму:
[vba]
Код
Option Explicit

Dim rngSource   As Range
Dim rngTarget   As Range

'подпрограмма обработки комбинаций типа A&B, A&C и т.д.
Sub doCombi(strRangeAddr, arrCols)

    Dim cell    As Range
    Dim col     As Variant 'Long
    
    For Each cell In Range(strRangeAddr)
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            For Each col In arrCols
                rngTarget.Cells(col) = rngSource.Cells(cell.row, col)
            Next col
            rngTarget.Cells(5) = cell.Value
        End If
    Next

End Sub

'ГЛАВНАЯ ПРОГРАММА, которую надо запускать
Sub io_v2()

    Dim i       As Long
    Dim ncnt    As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'читаем повторяющиеся комбинации
    'A&B
    doCombi "G2:G15", Array(1, 2)
    
    'A&C
    doCombi "I2:I15", Array(1, 3)
    
    'A&D
    doCombi "K2:K15", Array(1, 4)
    
    'A&D&B
    doCombi "M2:M15", Array(1, 2, 4)
       
       
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub
[/vba]

YOUGIN, сможете сами загрузить код в свой файл и запустить? Или мне подготовить рабочий файл?
Автор - Gustav
Дата добавления - 14.01.2026 в 21:37
Мир MS Excel » Вопросы и решения » Вопросы по Excel » получить таблицу с комбинациями и количеством повторов
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!