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

Вход

Регистрация

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

 

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

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

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

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

2019
Есть уже давно такая 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 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

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

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


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

Автор - Hugo
Дата добавления - 26.12.2017 в 12:15
sboy Дата: Вторник, 26.12.2017, 12:17 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 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 (16.7 Kb)


Яндекс: 410016850021169

Сообщение отредактировал 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

Автор - adamm1603
Дата добавления - 26.12.2017 в 13:22
adamm1603 Дата: Четверг, 15.02.2018, 19:45 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Всем привет! Поднимаю старую тему, так макрос, который мне любезно написал sboy, перестал работать выдаёт ошибку: "object doesn't support this property or method", гугл мне подсказал, что это "объект не поддерживает это свойство или метод", для меня лес дремучий... Пожскажите в чём проблема?
К сообщению приложен файл: 9106854.xlsm (16.7 Kb)
 
Ответить
СообщениеВсем привет! Поднимаю старую тему, так макрос, который мне любезно написал sboy, перестал работать выдаёт ошибку: "object doesn't support this property or method", гугл мне подсказал, что это "объект не поддерживает это свойство или метод", для меня лес дремучий... Пожскажите в чём проблема?

Автор - adamm1603
Дата добавления - 15.02.2018 в 19:45
Karataev Дата: Пятница, 16.02.2018, 09:07 | Сообщение № 10
Группа: Проверенные
Ранг: Старожил
Сообщений: 1334
Репутация: 533 ±
Замечаний: 0% ±

Excel
Выделять нужно смежные ячейки (без клавиши "Ctrl") в столбцах A:B, без шапки таблицы. Результат вставляется в "C2".
 
Ответить
СообщениеВыделять нужно смежные ячейки (без клавиши "Ctrl") в столбцах A:B, без шапки таблицы. Результат вставляется в "C2".

Автор - Karataev
Дата добавления - 16.02.2018 в 09:07
adamm1603 Дата: Пятница, 16.02.2018, 11:23 | Сообщение № 11
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
спасибо!
 
Ответить
Сообщениеспасибо!

Автор - adamm1603
Дата добавления - 16.02.2018 в 11:23
adamm1603 Дата: Пятница, 16.02.2018, 11:27 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Дико извиняюсь, тот макрос так же работал, просто нужно было область выделить, давно не пользовался забыл! Ещё раз спасибо!
 
Ответить
СообщениеДико извиняюсь, тот макрос так же работал, просто нужно было область выделить, давно не пользовался забыл! Ещё раз спасибо!

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

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