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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Генерация сочетаний слов по нескольким ячейкам (Макросы/Sub)
Генерация сочетаний слов по нескольким ячейкам
xaser Дата: Вторник, 03.05.2016, 15:45 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Приветствую. Помогите составить макрос.

Имеется несколько столбцов со словами. Необходимо получить все уникальные комбинации: по 1 слову из 1го, 2го и 3го столбцов.

На примере из аттача:

митсубиси asx купить
митсубиси asx отзывы
...
mitsubishi асх сравнение
К сообщению приложен файл: 4592372.xlsx(9Kb)
 
Ответить
СообщениеПриветствую. Помогите составить макрос.

Имеется несколько столбцов со словами. Необходимо получить все уникальные комбинации: по 1 слову из 1го, 2го и 3го столбцов.

На примере из аттача:

митсубиси asx купить
митсубиси asx отзывы
...
mitsubishi асх сравнение

Автор - xaser
Дата добавления - 03.05.2016 в 15:45
Karataev Дата: Вторник, 03.05.2016, 16:23 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 643
Репутация: 227 ±
Замечаний: 0% ±

Excel
Макрос вставляет результат на новый лист.
[vba]
Код
Sub jjj()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr1(), arr2(), arr3(), arrRes()
    Dim lr As Long, r As Long, i As Long, j As Long, k As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr1() = shSrc.Range("A1").Resize(lr).Value
    
    lr = shSrc.Columns("B").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr2() = shSrc.Range("B1").Resize(lr).Value
    
    lr = shSrc.Columns("C").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr3() = shSrc.Range("C1").Resize(lr).Value
    
    ReDim arrRes(1 To UBound(arr1) * UBound(arr2) * UBound(arr3), 1 To 1)
    
    For i = 1 To UBound(arr1)
        For j = 1 To UBound(arr2)
            For k = 1 To UBound(arr3)
                r = r + 1
                arrRes(r, 1) = arr1(i, 1) & " " & arr2(j, 1) & " " & arr3(k, 1)
            Next
        Next
    Next
    
    shRes.Range("A1").Resize(UBound(arrRes)).Value = arrRes()
    
    Application.ScreenUpdating = True
    
End Sub
[/vba]


 
Ответить
СообщениеМакрос вставляет результат на новый лист.
[vba]
Код
Sub jjj()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr1(), arr2(), arr3(), arrRes()
    Dim lr As Long, r As Long, i As Long, j As Long, k As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr1() = shSrc.Range("A1").Resize(lr).Value
    
    lr = shSrc.Columns("B").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr2() = shSrc.Range("B1").Resize(lr).Value
    
    lr = shSrc.Columns("C").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr3() = shSrc.Range("C1").Resize(lr).Value
    
    ReDim arrRes(1 To UBound(arr1) * UBound(arr2) * UBound(arr3), 1 To 1)
    
    For i = 1 To UBound(arr1)
        For j = 1 To UBound(arr2)
            For k = 1 To UBound(arr3)
                r = r + 1
                arrRes(r, 1) = arr1(i, 1) & " " & arr2(j, 1) & " " & arr3(k, 1)
            Next
        Next
    Next
    
    shRes.Range("A1").Resize(UBound(arrRes)).Value = arrRes()
    
    Application.ScreenUpdating = True
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 03.05.2016 в 16:23
xaser Дата: Вторник, 03.05.2016, 16:52 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Благодарю, то что нужно!
 
Ответить
СообщениеБлагодарю, то что нужно!

Автор - xaser
Дата добавления - 03.05.2016 в 16:52
xaser Дата: Вторник, 03.05.2016, 16:54 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Я знал что там перебор простой будет, только операторов нужных не знал :)


Сообщение отредактировал xaser - Вторник, 03.05.2016, 16:55
 
Ответить
СообщениеЯ знал что там перебор простой будет, только операторов нужных не знал :)

Автор - xaser
Дата добавления - 03.05.2016 в 16:54
xaser Дата: Вторник, 03.05.2016, 17:19 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Karataev, Можно расширить алгоритм для произвольного кол-ва столбцов?


Сообщение отредактировал xaser - Вторник, 03.05.2016, 17:20
 
Ответить
СообщениеKarataev, Можно расширить алгоритм для произвольного кол-ва столбцов?

Автор - xaser
Дата добавления - 03.05.2016 в 17:19
Karataev Дата: Среда, 04.05.2016, 21:55 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 643
Репутация: 227 ±
Замечаний: 0% ±

Excel
[vba]
Код
Sub jjj()

    Dim arr1(), arr2(), arrRes()
    Dim lr As Long, lc As Long, r As Long, c As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Copy After:=ActiveSheet
    
    lc = Rows(1).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
        
    For c = lc To 2 Step -1
    
        lr = Columns(c - 1).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
            , SearchFormat:=False).Row
        arr1() = Cells(1, c - 1).Resize(lr).Value
        
        lr = Columns(c).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
            , SearchFormat:=False).Row
        arr2() = Cells(1, c).Resize(lr).Value
        
        ReDim arrRes(1 To UBound(arr1) * UBound(arr2), 1 To 1)
        r = 0
        
        For i = 1 To UBound(arr1)
            For j = 1 To UBound(arr2)
                r = r + 1
                arrRes(r, 1) = arr1(i, 1) & " " & arr2(j, 1)
            Next
        Next
        
        Cells(1, c - 1).Resize(UBound(arrRes)).Value = arrRes()
        
        Columns(c).Value = Empty
        
    Next
        
    Application.ScreenUpdating = True
    
End Sub
[/vba]


 
Ответить
Сообщение[vba]
Код
Sub jjj()

    Dim arr1(), arr2(), arrRes()
    Dim lr As Long, lc As Long, r As Long, c As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Copy After:=ActiveSheet
    
    lc = Rows(1).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
        
    For c = lc To 2 Step -1
    
        lr = Columns(c - 1).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
            , SearchFormat:=False).Row
        arr1() = Cells(1, c - 1).Resize(lr).Value
        
        lr = Columns(c).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
            , SearchFormat:=False).Row
        arr2() = Cells(1, c).Resize(lr).Value
        
        ReDim arrRes(1 To UBound(arr1) * UBound(arr2), 1 To 1)
        r = 0
        
        For i = 1 To UBound(arr1)
            For j = 1 To UBound(arr2)
                r = r + 1
                arrRes(r, 1) = arr1(i, 1) & " " & arr2(j, 1)
            Next
        Next
        
        Cells(1, c - 1).Resize(UBound(arrRes)).Value = arrRes()
        
        Columns(c).Value = Empty
        
    Next
        
    Application.ScreenUpdating = True
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 04.05.2016 в 21:55
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Генерация сочетаний слов по нескольким ячейкам (Макросы/Sub)
Страница 1 из 11
Поиск:

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