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

Вход

Регистрация

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

 

= Мир MS Excel/Объединение ячейки через знак препинание - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Объединение ячейки через знак препинание (Формулы/Formulas)
Объединение ячейки через знак препинание
4step Дата: Вторник, 05.07.2022, 15:12 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

Добрый день! Возможно ли объединить ячейку по значениям с дальнейшим выводом в соседнею ячейку через "; "?
К сообщению приложен файл: 5748253.xlsx(10.0 Kb)


Сообщение отредактировал Serge_007 - Вторник, 05.07.2022, 17:18
 
Ответить
СообщениеДобрый день! Возможно ли объединить ячейку по значениям с дальнейшим выводом в соседнею ячейку через "; "?

Автор - 4step
Дата добавления - 05.07.2022 в 15:12
msi2102 Дата: Вторник, 05.07.2022, 20:24 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 171
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007
Возможно ли объединить ячейку

Можно только не понятно зачем мы их разъединяли :D
Также пользовательской функцией, только теперь может работать как массивная или там же есть обычная. Если будет подтормаживать, то можно переделать в простой макрос, это несложно

[vba]
Код
Public Function Сборка_мас(ByRef rng As Range)
Dim n, arr(), s As String, x As String, y As Integer, m As Byte, rn As Range
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("Scripting.Dictionary")
re.Global = True: re.Pattern = "\d+"
ReDim arr(1 To rng.Rows.Count, 1 To 1)
k = 0
For Each rn In rng
    k = k + 1
    s = Replace(Replace(rn, ",", ";"), " ", "")
    arr1 = Split(s, ";")
    For Each n In arr1
        If n <> "" Then
            x = re.Replace(n, "")
            y = CInt(Replace(n, x, ""))
            If Not dic.Exists(x) Then Set dic(x) = CreateObject("System.Collections.SortedList")
            If Not dic(x).contains(y) Then dic(x).Add y, y
        End If
    Next n
    s = ""
    m = 0
    For Each n In dic
        If dic(n).Count > 1 Then
            For y = 0 To dic(n).Count - 2
                If dic(n).GetKey(y) = dic(n).GetKey(y + 1) - 1 Then
                    m = m + 1
                ElseIf dic(n).GetKey(y) <> dic(n).GetKey(y + 1) - 1 And m > 0 Then
                    s = s & "; " & n & Format(dic(n).GetKey(y - m), "0##") & "-" & n & Format(dic(n).GetKey(y), "0##")
                    m = 0
                ElseIf dic(n).GetKey(y) <> dic(n).GetKey(y + 1) - 1 And m = 0 Then
                    s = s & "; " & n & Format(dic(n).GetKey(y), "0##")
                    m = 0
                End If
            Next
            If m <> 0 Then
                s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - m - 1), "0##") & "-" & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
            Else
                s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
            End If
        Else
            s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
        End If
        m = 0
        Set dic(n) = Nothing
    Next n
    arr(k, 1) = Mid(s, 3)
    dic.RemoveAll
Next rn
Сборка_мас = arr
Exit Function
ErrHand:
Сборка_мас = "Ошибка"
End Function
[/vba]
К сообщению приложен файл: 6715875.xlsm(26.8 Kb)


Сообщение отредактировал msi2102 - Среда, 06.07.2022, 11:12
 
Ответить
Сообщение
Возможно ли объединить ячейку

Можно только не понятно зачем мы их разъединяли :D
Также пользовательской функцией, только теперь может работать как массивная или там же есть обычная. Если будет подтормаживать, то можно переделать в простой макрос, это несложно

[vba]
Код
Public Function Сборка_мас(ByRef rng As Range)
Dim n, arr(), s As String, x As String, y As Integer, m As Byte, rn As Range
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("Scripting.Dictionary")
re.Global = True: re.Pattern = "\d+"
ReDim arr(1 To rng.Rows.Count, 1 To 1)
k = 0
For Each rn In rng
    k = k + 1
    s = Replace(Replace(rn, ",", ";"), " ", "")
    arr1 = Split(s, ";")
    For Each n In arr1
        If n <> "" Then
            x = re.Replace(n, "")
            y = CInt(Replace(n, x, ""))
            If Not dic.Exists(x) Then Set dic(x) = CreateObject("System.Collections.SortedList")
            If Not dic(x).contains(y) Then dic(x).Add y, y
        End If
    Next n
    s = ""
    m = 0
    For Each n In dic
        If dic(n).Count > 1 Then
            For y = 0 To dic(n).Count - 2
                If dic(n).GetKey(y) = dic(n).GetKey(y + 1) - 1 Then
                    m = m + 1
                ElseIf dic(n).GetKey(y) <> dic(n).GetKey(y + 1) - 1 And m > 0 Then
                    s = s & "; " & n & Format(dic(n).GetKey(y - m), "0##") & "-" & n & Format(dic(n).GetKey(y), "0##")
                    m = 0
                ElseIf dic(n).GetKey(y) <> dic(n).GetKey(y + 1) - 1 And m = 0 Then
                    s = s & "; " & n & Format(dic(n).GetKey(y), "0##")
                    m = 0
                End If
            Next
            If m <> 0 Then
                s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - m - 1), "0##") & "-" & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
            Else
                s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
            End If
        Else
            s = s & "; " & n & Format(dic(n).GetKey(dic(n).Count - 1), "0##")
        End If
        m = 0
        Set dic(n) = Nothing
    Next n
    arr(k, 1) = Mid(s, 3)
    dic.RemoveAll
Next rn
Сборка_мас = arr
Exit Function
ErrHand:
Сборка_мас = "Ошибка"
End Function
[/vba]

Автор - msi2102
Дата добавления - 05.07.2022 в 20:24
4step Дата: Среда, 06.07.2022, 12:40 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

msi2102, добавил новую таблицу "2 в 1", разбил функционалы по вкладкам "ОБЪЕДИНИТЬ" и "РАЗЪЕДИНИТЬ". Можно ли попросить выполнить эти функции макросами или формулами начиная от столбца "B3" вниз? А также выполнить сортировку в алфавитном порядке? Также может быть между буквой лат. и порядковым номером тоже быть пробел.
К сообщению приложен файл: 8493241.xlsm(21.7 Kb)


Сообщение отредактировал 4step - Среда, 06.07.2022, 12:55
 
Ответить
Сообщениеmsi2102, добавил новую таблицу "2 в 1", разбил функционалы по вкладкам "ОБЪЕДИНИТЬ" и "РАЗЪЕДИНИТЬ". Можно ли попросить выполнить эти функции макросами или формулами начиная от столбца "B3" вниз? А также выполнить сортировку в алфавитном порядке? Также может быть между буквой лат. и порядковым номером тоже быть пробел.

Автор - 4step
Дата добавления - 06.07.2022 в 12:40
4step Дата: Среда, 06.07.2022, 12:43 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

не понятно зачем мы их разъединяли

Эти операции нужны для формирования перечня элементов по ГОСТ 2.701-84.
 
Ответить
Сообщение
не понятно зачем мы их разъединяли

Эти операции нужны для формирования перечня элементов по ГОСТ 2.701-84.

Автор - 4step
Дата добавления - 06.07.2022 в 12:43
msi2102 Дата: Среда, 06.07.2022, 14:45 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 171
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007
4step, Я уже писал подобный макрос по сбору значений ТУТ (он в Вашем в файле). Там он работает именно так как Вы хотели. Только разделители должны быть одиниковые


Сообщение отредактировал msi2102 - Среда, 06.07.2022, 14:48
 
Ответить
Сообщение4step, Я уже писал подобный макрос по сбору значений ТУТ (он в Вашем в файле). Там он работает именно так как Вы хотели. Только разделители должны быть одиниковые

Автор - msi2102
Дата добавления - 06.07.2022 в 14:45
msi2102 Дата: Среда, 06.07.2022, 17:21 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 171
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007
Немного подредактировал макрос. Не совсем понятно, как должен работать макрос например при таком наборе: X1.1,X2.1,X3.1,Y1.1,Y1.2,Y1.3 или таком X1.1,X2.1,X3.1,X1.2,X1.3,Y1.1,Y1.2,Y1.3.
Сравнительный анализ результатов, приведен в файле, особенно видна разница в строках выделенных желтым цветом.
В файле три макроса:
1. "Порядок", совсем старый, с Планеты, редактировать его не буду, потому что уже не помню, что писал, вникать нет времени;
2. "Сборка", отредактированный из сообщения №2, теперь собирает алфавитному по порядку;
3. "Сборка_1", тоже самое, что "Сборка", немного изменён алгоритм проверки последовательности.
Макросы "Сборка" и "Сборка_1", работают по принципу: группа букв + число (1.1 или 1.2 тоже считаются, как числа, но с дробной частью), не важно в каком порядке, например последовательность 33А;34А;А35;А36 объединит в 33А-А36, если порядок: буквы - числа важен, то нужно дописывать макрос (сейчас нет времени этим заниматься), Макрос "Порядок" не найдет совсем значения начинающиеся с чисел. Зато порядок объединяет такие значения как: XT1.PE1;XT1.PE2;XT1.PE3, результат будет XT1.PE1-XT1.PE3, а макросы "Сборка" вставят их как отдельные позиции XT1.PE1;XT1.PE2;XT1.PE3.
Прежде чем создавать тему Вы должны продумать все варианты, а не так: "У меня новый пример, переделайте мне макрос под него", порой для этого нужно полностью изменить подход к решению, а следовательно приходится писать всё заново. Я не знаю кому как, но у меня точно пропадает желание переписывать его.
К сообщению приложен файл: 1-14-.xlsm(27.0 Kb)


Сообщение отредактировал msi2102 - Среда, 06.07.2022, 17:25
 
Ответить
СообщениеНемного подредактировал макрос. Не совсем понятно, как должен работать макрос например при таком наборе: X1.1,X2.1,X3.1,Y1.1,Y1.2,Y1.3 или таком X1.1,X2.1,X3.1,X1.2,X1.3,Y1.1,Y1.2,Y1.3.
Сравнительный анализ результатов, приведен в файле, особенно видна разница в строках выделенных желтым цветом.
В файле три макроса:
1. "Порядок", совсем старый, с Планеты, редактировать его не буду, потому что уже не помню, что писал, вникать нет времени;
2. "Сборка", отредактированный из сообщения №2, теперь собирает алфавитному по порядку;
3. "Сборка_1", тоже самое, что "Сборка", немного изменён алгоритм проверки последовательности.
Макросы "Сборка" и "Сборка_1", работают по принципу: группа букв + число (1.1 или 1.2 тоже считаются, как числа, но с дробной частью), не важно в каком порядке, например последовательность 33А;34А;А35;А36 объединит в 33А-А36, если порядок: буквы - числа важен, то нужно дописывать макрос (сейчас нет времени этим заниматься), Макрос "Порядок" не найдет совсем значения начинающиеся с чисел. Зато порядок объединяет такие значения как: XT1.PE1;XT1.PE2;XT1.PE3, результат будет XT1.PE1-XT1.PE3, а макросы "Сборка" вставят их как отдельные позиции XT1.PE1;XT1.PE2;XT1.PE3.
Прежде чем создавать тему Вы должны продумать все варианты, а не так: "У меня новый пример, переделайте мне макрос под него", порой для этого нужно полностью изменить подход к решению, а следовательно приходится писать всё заново. Я не знаю кому как, но у меня точно пропадает желание переписывать его.

Автор - msi2102
Дата добавления - 06.07.2022 в 17:21
4step Дата: Четверг, 07.07.2022, 01:37 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

msi2102, добавил комментарии по каждой строке таблицы, а также указал пример расшифровку обозначения оборудования.
К сообщению приложен файл: 1177394.xlsm(28.0 Kb)


Сообщение отредактировал 4step - Четверг, 07.07.2022, 01:40
 
Ответить
Сообщениеmsi2102, добавил комментарии по каждой строке таблицы, а также указал пример расшифровку обозначения оборудования.

Автор - 4step
Дата добавления - 07.07.2022 в 01:37
msi2102 Дата: Четверг, 07.07.2022, 16:33 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 171
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007
Проверяйте
[vba]
Код
Public Function Сборка(ByRef rng As Range)
Dim n, s As String, x As String, y, m As Byte
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("System.Collections.SortedList")
re.Global = True: re.Pattern = "\d+(\.\d+)?$"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
Arr1 = Split(s, ";")
For Each n In Arr1
    If n <> "" Then
        If re.Test(n) Then
            x = re.Replace(n, "")
            a = Split(Replace(n, x, ""), ".")
            y = CInt(a(0))
            If UBound(a) > 0 Then y1 = CDbl(a(1)) / 10000 Else y1 = CDbl(0)
            y = Fix(y) + y1
            If Not dic.Contains(x) Then Set dic(x) = CreateObject("System.Collections.SortedList")
            If Not dic(x).Contains(y) Then dic(x).Add y, n
        Else
            If Not dic.Contains(n) Then Set dic(n) = CreateObject("System.Collections.SortedList")
            If Not dic(n).Contains(n) Then dic(n).Add n, n
        End If
    End If
Next n
s = ""
m = 0
For n = 0 To dic.Count - 1
    If dic(dic.GetKey(n)).Count > 1 Then
        For y = 0 To dic(dic.GetKey(n)).Count - 2
            If Round(Fix(dic(dic.GetKey(n)).GetKey(y)) - Round(dic(dic.GetKey(n)).GetKey(y), 4), 4) = 0 Then f = 1 Else f = 0.0001
            If Round(dic(dic.GetKey(n)).GetKey(y + 1) - dic(dic.GetKey(n)).GetKey(y), 4) = f Then
                m = m + 1
            ElseIf Round(dic(dic.GetKey(n)).GetKey(y + 1) - dic(dic.GetKey(n)).GetKey(y), 4) <> f Then
                If m > 0 Then
                    s = s & "; " & dic(dic.GetKey(n)).GetByIndex(y - m) & "-" & dic(dic.GetKey(n)).GetByIndex(y)
                    m = 0
                ElseIf m = 0 Then
                    s = s & "; " & dic(dic.GetKey(n)).GetByIndex(y)
                    m = 0
                End If
            End If
        Next
        If m <> 0 Then
            s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - m - 1) & "-" & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
            m = 0
        Else
            s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
        End If
    Else
        s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
        m = 0
    End If
    Set dic(dic.GetKey(n)) = Nothing
Next n
Сборка = Mid(s, 3)
Set dic = Nothing
Exit Function
ErrHand:
Сборка = "Ошибка"
End Function
[/vba]
К сообщению приложен файл: 1177394_3-1-.xlsm(25.8 Kb)


Сообщение отредактировал msi2102 - Четверг, 07.07.2022, 19:15
 
Ответить
СообщениеПроверяйте
[vba]
Код
Public Function Сборка(ByRef rng As Range)
Dim n, s As String, x As String, y, m As Byte
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("System.Collections.SortedList")
re.Global = True: re.Pattern = "\d+(\.\d+)?$"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
Arr1 = Split(s, ";")
For Each n In Arr1
    If n <> "" Then
        If re.Test(n) Then
            x = re.Replace(n, "")
            a = Split(Replace(n, x, ""), ".")
            y = CInt(a(0))
            If UBound(a) > 0 Then y1 = CDbl(a(1)) / 10000 Else y1 = CDbl(0)
            y = Fix(y) + y1
            If Not dic.Contains(x) Then Set dic(x) = CreateObject("System.Collections.SortedList")
            If Not dic(x).Contains(y) Then dic(x).Add y, n
        Else
            If Not dic.Contains(n) Then Set dic(n) = CreateObject("System.Collections.SortedList")
            If Not dic(n).Contains(n) Then dic(n).Add n, n
        End If
    End If
Next n
s = ""
m = 0
For n = 0 To dic.Count - 1
    If dic(dic.GetKey(n)).Count > 1 Then
        For y = 0 To dic(dic.GetKey(n)).Count - 2
            If Round(Fix(dic(dic.GetKey(n)).GetKey(y)) - Round(dic(dic.GetKey(n)).GetKey(y), 4), 4) = 0 Then f = 1 Else f = 0.0001
            If Round(dic(dic.GetKey(n)).GetKey(y + 1) - dic(dic.GetKey(n)).GetKey(y), 4) = f Then
                m = m + 1
            ElseIf Round(dic(dic.GetKey(n)).GetKey(y + 1) - dic(dic.GetKey(n)).GetKey(y), 4) <> f Then
                If m > 0 Then
                    s = s & "; " & dic(dic.GetKey(n)).GetByIndex(y - m) & "-" & dic(dic.GetKey(n)).GetByIndex(y)
                    m = 0
                ElseIf m = 0 Then
                    s = s & "; " & dic(dic.GetKey(n)).GetByIndex(y)
                    m = 0
                End If
            End If
        Next
        If m <> 0 Then
            s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - m - 1) & "-" & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
            m = 0
        Else
            s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
        End If
    Else
        s = s & "; " & dic(dic.GetKey(n)).GetByIndex(dic(dic.GetKey(n)).Count - 1)
        m = 0
    End If
    Set dic(dic.GetKey(n)) = Nothing
Next n
Сборка = Mid(s, 3)
Set dic = Nothing
Exit Function
ErrHand:
Сборка = "Ошибка"
End Function
[/vba]

Автор - msi2102
Дата добавления - 07.07.2022 в 16:33
4step Дата: Пятница, 08.07.2022, 13:08 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

msi2102, благодарю! Очень пригодится функция. =)
 
Ответить
Сообщениеmsi2102, благодарю! Очень пригодится функция. =)

Автор - 4step
Дата добавления - 08.07.2022 в 13:08
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Объединение ячейки через знак препинание (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

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