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

Вход

Регистрация

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

 

= Мир MS Excel/Перестановки с повторениями, вывод уникальных значений - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перестановки с повторениями, вывод уникальных значений (Макросы/Sub)
Перестановки с повторениями, вывод уникальных значений
convive Дата: Суббота, 17.02.2018, 13:54 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Доброго времени суток всем!

Дана задача: Рассчитайте количество и выведите все уникальные последовательности из символов: E, E, A, B, C

Задача решена на листе "задача и расчёт" с помощью формул, но также требуется вывести уникальные значения. В сети нашёл подходящий код, но он выводит все значения как уникальные, т.к. букв E - 2, то и результатов 120, а должно быть 60.

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

Буду благодарен за любую помощь!

[vba]
Код
Dim r As Long, c As Long

Sub main()
c = 2
r = 0
Pn "EEABC"
End Sub

Public Sub Pn(S As String, Optional SS As String = "")
Dim i As Integer
If Len(S) = 1 Then
r = r + 1
If r > Rows.Count Then c = c + 1: r = 1
Cells(r, c) = SS & S
Else
For i = 1 To Len(S)
Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
Next
End If
End Sub
[/vba]
К сообщению приложен файл: __.xlsm (61.1 Kb)


Сообщение отредактировал convive - Суббота, 17.02.2018, 15:18
 
Ответить
СообщениеДоброго времени суток всем!

Дана задача: Рассчитайте количество и выведите все уникальные последовательности из символов: E, E, A, B, C

Задача решена на листе "задача и расчёт" с помощью формул, но также требуется вывести уникальные значения. В сети нашёл подходящий код, но он выводит все значения как уникальные, т.к. букв E - 2, то и результатов 120, а должно быть 60.

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

Буду благодарен за любую помощь!

[vba]
Код
Dim r As Long, c As Long

Sub main()
c = 2
r = 0
Pn "EEABC"
End Sub

Public Sub Pn(S As String, Optional SS As String = "")
Dim i As Integer
If Len(S) = 1 Then
r = r + 1
If r > Rows.Count Then c = c + 1: r = 1
Cells(r, c) = SS & S
Else
For i = 1 To Len(S)
Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
Next
End If
End Sub
[/vba]

Автор - convive
Дата добавления - 17.02.2018 в 13:54
Gustav Дата: Суббота, 17.02.2018, 14:34 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2697
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
В "Готовых решениях" смотрели тему?

[p.s.]Уникальные перестановки можно получить с помощью объекта "Словарь". Поищите по строке: CreateObject("Scripting.Dictionary"). На Форуме много примеров.[/p.s.]


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Суббота, 17.02.2018, 14:42
 
Ответить
СообщениеВ "Готовых решениях" смотрели тему?

[p.s.]Уникальные перестановки можно получить с помощью объекта "Словарь". Поищите по строке: CreateObject("Scripting.Dictionary"). На Форуме много примеров.[/p.s.]

Автор - Gustav
Дата добавления - 17.02.2018 в 14:34
Pelena Дата: Суббота, 17.02.2018, 15:00 | Сообщение № 3
Группа: Админы
Ранг: Местный житель
Сообщений: 19162
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
convive, оформите код тегами с помощью кнопки # в режиме правки поста


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеconvive, оформите код тегами с помощью кнопки # в режиме правки поста

Автор - Pelena
Дата добавления - 17.02.2018 в 15:00
convive Дата: Суббота, 17.02.2018, 15:06 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Поищите по строке: CreateObject("Scripting.Dictionary")


В готовых смотрел, по приведённой Вами ссылке перестановка без повторений, у меня - с повторениями.
По поиску Scripting.Dictionary нашёл только одну тему, но там вопрос не раскрыт( Буду искать дальше.

convive, оформите код тегами с помощью кнопки # в режиме правки поста


буду знать, спасибо!


Сообщение отредактировал convive - Суббота, 17.02.2018, 15:13
 
Ответить
Сообщение
Поищите по строке: CreateObject("Scripting.Dictionary")


В готовых смотрел, по приведённой Вами ссылке перестановка без повторений, у меня - с повторениями.
По поиску Scripting.Dictionary нашёл только одну тему, но там вопрос не раскрыт( Буду искать дальше.

convive, оформите код тегами с помощью кнопки # в режиме правки поста


буду знать, спасибо!

Автор - convive
Дата добавления - 17.02.2018 в 15:06
convive Дата: Понедельник, 19.02.2018, 00:04 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Прикрутил удаление дублей, вроде работает, но не красиво конечно.
Всё ещё в поисках лучшего решения.
 
Ответить
СообщениеПрикрутил удаление дублей, вроде работает, но не красиво конечно.
Всё ещё в поисках лучшего решения.

Автор - convive
Дата добавления - 19.02.2018 в 00:04
Pelena Дата: Понедельник, 19.02.2018, 07:12 | Сообщение № 6
Группа: Админы
Ранг: Местный житель
Сообщений: 19162
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Попробуйте так
[vba]
Код
Public Sub Pn(S As String, Optional SS As String = "")
Dim i As Integer
  If Len(S) = 1 Then
    r = r + 1
    If r > Rows.Count Then c = c + 1: r = 1
    Cells(r, c) = SS & S
  Else
    For i = 1 To Len(S)
        If InStr(Left(S, i - 1), Mid(S, i, 1)) = 0 Then
            Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
        End If
    Next
  End If
End Sub
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеПопробуйте так
[vba]
Код
Public Sub Pn(S As String, Optional SS As String = "")
Dim i As Integer
  If Len(S) = 1 Then
    r = r + 1
    If r > Rows.Count Then c = c + 1: r = 1
    Cells(r, c) = SS & S
  Else
    For i = 1 To Len(S)
        If InStr(Left(S, i - 1), Mid(S, i, 1)) = 0 Then
            Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
        End If
    Next
  End If
End Sub
[/vba]

Автор - Pelena
Дата добавления - 19.02.2018 в 07:12
Gustav Дата: Понедельник, 19.02.2018, 13:07 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2697
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Для коллекции - еще версия со "Словарём":
[vba]
Код
Option Explicit

Dim dicObject As Object

Sub main()
    Set dicObject = CreateObject("Scripting.Dictionary")
    Pn "EEABC"
    Range("B1").Resize(UBound(dicObject.Keys()) + 1) = WorksheetFunction.Transpose(dicObject.Keys())
End Sub

Public Sub Pn(S As String, Optional SS As String = "")
    Dim i As Integer
    If Len(S) = 1 Then
        If Not dicObject.Exists(SS & S) Then dicObject.Add SS & S, ""
    Else
        For i = 1 To Len(S)
            Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
        Next
    End If
End Sub
[/vba]


МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеДля коллекции - еще версия со "Словарём":
[vba]
Код
Option Explicit

Dim dicObject As Object

Sub main()
    Set dicObject = CreateObject("Scripting.Dictionary")
    Pn "EEABC"
    Range("B1").Resize(UBound(dicObject.Keys()) + 1) = WorksheetFunction.Transpose(dicObject.Keys())
End Sub

Public Sub Pn(S As String, Optional SS As String = "")
    Dim i As Integer
    If Len(S) = 1 Then
        If Not dicObject.Exists(SS & S) Then dicObject.Add SS & S, ""
    Else
        For i = 1 To Len(S)
            Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
        Next
    End If
End Sub
[/vba]

Автор - Gustav
Дата добавления - 19.02.2018 в 13:07
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перестановки с повторениями, вывод уникальных значений (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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