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

Вход

Регистрация

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

 

= Мир MS Excel/Сцепить ячейки по заданному алгоритму - Мир MS Excel

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

Excel 2013
Всем привет! Нужна помощь с макросом, необходимо сцепить ячейки в определённой последовательности и подставить знаки препинания, в примере более конкретно показано, буду благодарен за помощь
К сообщению приложен файл: 6847193.xlsx(11Kb)
 
Ответить
СообщениеВсем привет! Нужна помощь с макросом, необходимо сцепить ячейки в определённой последовательности и подставить знаки препинания, в примере более конкретно показано, буду благодарен за помощь

Автор - adamm1603
Дата добавления - 26.12.2017 в 11:28
Hugo Дата: Вторник, 26.12.2017, 11:45 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2737
Репутация: 609 ±
Замечаний: 0% ±

Есть уже давно такая UDF:
[vba]
Код
="Узел 1 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 1";2;" ,") & "; " & "Узел 2 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 2";2;" ,") & "; " & "Узел 3 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 3";2;" ,")
[/vba]
код:
[vba]
Код
Function VLOOKUPCOUPLE(Table As Variant, _
                       SearchColumnNum As Integer, _
                       SearchValue As Variant, _
                       RezultColumnNum As Integer, _
                       Separator_ As String, _
                       Optional BezPovtorov As Boolean = True)

'Table - таблица, где ищем
'SearchColumnNum - столбец, где ищем
'SearchValue - данные, которые ищем
'RezultColumnNum - столбец, откуда берём результат
'Separator_ - разделитель, желательно вводить с пробелом в конце
'BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения

    Dim i As Long, tmp As String, vlk

    If TypeName(Table) = "Range" Then Table = Intersect(Table.Parent.UsedRange, Table).Value
    If BezPovtorov Then
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Table)
                If Table(i, SearchColumnNum) = SearchValue Then
                    tmp = Table(i, RezultColumnNum)
                    If tmp <> "" Then
                        If Not .Exists(tmp) Then
                            .Add tmp, 0&
                            vlk = vlk & Separator_ & Table(i, RezultColumnNum)
                        End If
                    End If
                End If
            Next i
        End With
    Else
        For i = 1 To UBound(Table)
            If Table(i, SearchColumnNum) = SearchValue Then
                vlk = vlk & Separator_ & Table(i, RezultColumnNum)
            End If
        Next i
    End If
    If vlk > 0 Then vlk = Mid(vlk, Len(Separator_) + 1) Else vlk = ""
    VLOOKUPCOUPLE = vlk
End Function
[/vba]
И там в примере ошибочка с " Узел 2 стыки 5 ,5* ,2 ,2* ,3 ,3* ,4 ,4* ,1 ,1* ,2 ,2* " - зачем повторяться?

скрин


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069


Сообщение отредактировал Hugo - Вторник, 26.12.2017, 11:48
 
Ответить
СообщениеЕсть уже давно такая UDF:
[vba]
Код
="Узел 1 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 1";2;" ,") & "; " & "Узел 2 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 2";2;" ,") & "; " & "Узел 3 стыки " & VLOOKUPCOUPLE(A:B;1;"Узел 3";2;" ,")
[/vba]
код:
[vba]
Код
Function VLOOKUPCOUPLE(Table As Variant, _
                       SearchColumnNum As Integer, _
                       SearchValue As Variant, _
                       RezultColumnNum As Integer, _
                       Separator_ As String, _
                       Optional BezPovtorov As Boolean = True)

'Table - таблица, где ищем
'SearchColumnNum - столбец, где ищем
'SearchValue - данные, которые ищем
'RezultColumnNum - столбец, откуда берём результат
'Separator_ - разделитель, желательно вводить с пробелом в конце
'BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения

    Dim i As Long, tmp As String, vlk

    If TypeName(Table) = "Range" Then Table = Intersect(Table.Parent.UsedRange, Table).Value
    If BezPovtorov Then
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Table)
                If Table(i, SearchColumnNum) = SearchValue Then
                    tmp = Table(i, RezultColumnNum)
                    If tmp <> "" Then
                        If Not .Exists(tmp) Then
                            .Add tmp, 0&
                            vlk = vlk & Separator_ & Table(i, RezultColumnNum)
                        End If
                    End If
                End If
            Next i
        End With
    Else
        For i = 1 To UBound(Table)
            If Table(i, SearchColumnNum) = SearchValue Then
                vlk = vlk & Separator_ & Table(i, RezultColumnNum)
            End If
        Next i
    End If
    If vlk > 0 Then vlk = Mid(vlk, Len(Separator_) + 1) Else vlk = ""
    VLOOKUPCOUPLE = vlk
End Function
[/vba]
И там в примере ошибочка с " Узел 2 стыки 5 ,5* ,2 ,2* ,3 ,3* ,4 ,4* ,1 ,1* ,2 ,2* " - зачем повторяться?

скрин

Автор - Hugo
Дата добавления - 26.12.2017 в 11:45
adamm1603 Дата: Вторник, 26.12.2017, 11:48 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 125
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Да согласен залипончик, большое спасибо буду пробовать!
 
Ответить
СообщениеДа согласен залипончик, большое спасибо буду пробовать!

Автор - adamm1603
Дата добавления - 26.12.2017 в 11:48
adamm1603 Дата: Вторник, 26.12.2017, 12:04 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 125
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Функция не плохая, но проблема в том, что узлов у меня бывает больше сотни и вбивать каждый раз ручками очень долго, может есть какое то другое решение?
 
Ответить
СообщениеФункция не плохая, но проблема в том, что узлов у меня бывает больше сотни и вбивать каждый раз ручками очень долго, может есть какое то другое решение?

Автор - adamm1603
Дата добавления - 26.12.2017 в 12:04
Hugo Дата: Вторник, 26.12.2017, 12:15 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2737
Репутация: 609 ±
Замечаний: 0% ±

Про то, что больше сотни, и бывает - можно было сразу сказать.
Я ориентировался на то, что дано - есть ограниченное количество узлов, все они есть в данных, надобно слепитиь таким образом.
Если же узлов много, неизвесно сколько и какие есть - тогда конечно лучше макросом делать, ну хотя бы выявить в словарь или коллекцию все существующие узлы, чтоб потом сгенерить строку для UDF :)
Шучу, тогда уж сразу макросм всё и делать. Только куда Вы такую длиннючую строку далее применять будете?


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеПро то, что больше сотни, и бывает - можно было сразу сказать.
Я ориентировался на то, что дано - есть ограниченное количество узлов, все они есть в данных, надобно слепитиь таким образом.
Если же узлов много, неизвесно сколько и какие есть - тогда конечно лучше макросом делать, ну хотя бы выявить в словарь или коллекцию все существующие узлы, чтоб потом сгенерить строку для UDF :)
Шучу, тогда уж сразу макросм всё и делать. Только куда Вы такую длиннючую строку далее применять будете?

Автор - Hugo
Дата добавления - 26.12.2017 в 12:15
sboy Дата: Вторник, 26.12.2017, 12:17 | Сообщение № 6
Группа: Проверенные
Ранг: Старожил
Сообщений: 1268
Репутация: 338 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
[vba]
Код
Sub join_()
n_ = Selection.Value
Dim r0_()
ReDim r0_(0)
Dim r1_()
ReDim r1_(0)
    For x = 1 To UBound(n_)
        r0_(UBound(r0_)) = n_(x, 1) & " стыки "
        'ReDim Preserve r0_(UBound(r0_) + 1)
            Do While n_(x, 1) = n_(x + 1, 1)
                r1_(UBound(r1_)) = n_(x, 2)
                ReDim Preserve r1_(UBound(r1_) + 1)
                x = x + 1
                    If x = UBound(n_) Then Exit Do
            Loop
        r1_(UBound(r1_)) = n_(x, 2)
        r0_(UBound(r0_)) = r0_(UBound(r0_)) & Join(r1_, " ,")
        ReDim Preserve r0_(UBound(r0_) + 1)
        ReDim r1_(0)
    Next
    ReDim Preserve r0_(UBound(r0_) - 1)
    result = Join(r0_, "; ")
    Selection.Cells(1).Offset(1, 2) = result
End Sub
[/vba]
К сообщению приложен файл: 6847193.xlsm(17Kb)


Сообщение отредактировал sboy - Вторник, 26.12.2017, 12:18
 
Ответить
СообщениеДобрый день.
[vba]
Код
Sub join_()
n_ = Selection.Value
Dim r0_()
ReDim r0_(0)
Dim r1_()
ReDim r1_(0)
    For x = 1 To UBound(n_)
        r0_(UBound(r0_)) = n_(x, 1) & " стыки "
        'ReDim Preserve r0_(UBound(r0_) + 1)
            Do While n_(x, 1) = n_(x + 1, 1)
                r1_(UBound(r1_)) = n_(x, 2)
                ReDim Preserve r1_(UBound(r1_) + 1)
                x = x + 1
                    If x = UBound(n_) Then Exit Do
            Loop
        r1_(UBound(r1_)) = n_(x, 2)
        r0_(UBound(r0_)) = r0_(UBound(r0_)) & Join(r1_, " ,")
        ReDim Preserve r0_(UBound(r0_) + 1)
        ReDim r1_(0)
    Next
    ReDim Preserve r0_(UBound(r0_) - 1)
    result = Join(r0_, "; ")
    Selection.Cells(1).Offset(1, 2) = result
End Sub
[/vba]

Автор - sboy
Дата добавления - 26.12.2017 в 12:17
adamm1603 Дата: Вторник, 26.12.2017, 13:18 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 125
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Hugo, данная строка применяется в заключении (акте), сначала я делаю заявку, а после контроля (выполнения работ) мне печатают заключение (акт) и это происходит очень долго так как это всё в ручную, а с помощью макроса моментально
sboy, спасибо буду пробовать!
 
Ответить
СообщениеHugo, данная строка применяется в заключении (акте), сначала я делаю заявку, а после контроля (выполнения работ) мне печатают заключение (акт) и это происходит очень долго так как это всё в ручную, а с помощью макроса моментально
sboy, спасибо буду пробовать!

Автор - adamm1603
Дата добавления - 26.12.2017 в 13:18
adamm1603 Дата: Вторник, 26.12.2017, 13:22 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 125
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
sboy, огромное спасибо всё супер
 
Ответить
Сообщениеsboy, огромное спасибо всё супер

Автор - adamm1603
Дата добавления - 26.12.2017 в 13:22
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сцепить ячейки по заданному алгоритму (Макросы/Sub)
Страница 1 из 11
Поиск:

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