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

Вход

Регистрация

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

 

= Мир MS Excel/Сцепить ячейки с сохранение подстрочных букв - Мир MS Excel

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

Доброго дня. Столкнулся с проблемой. Есть необходимость сцепить ячейки с сохранением форматирования, а именно подстрочных букв. Формула сцепить, как понял, для этого бесполезна. Прошу помочь решить задачу. В макросах не очень разбираюсь. Спасибо.
К сообщению приложен файл: 123.xlsx(11Kb)
 
Ответить
СообщениеДоброго дня. Столкнулся с проблемой. Есть необходимость сцепить ячейки с сохранением форматирования, а именно подстрочных букв. Формула сцепить, как понял, для этого бесполезна. Прошу помочь решить задачу. В макросах не очень разбираюсь. Спасибо.

Автор - NIC
Дата добавления - 11.08.2016 в 15:15
Udik Дата: Четверг, 11.08.2016, 16:44 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1201
Репутация: 152 ±
Замечаний: 0% ±

Excel 2013
Похоже это через макросы надо решать.


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеПохоже это через макросы надо решать.

Автор - Udik
Дата добавления - 11.08.2016 в 16:44
Karataev Дата: Четверг, 11.08.2016, 16:49 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Макрос сделан для файла из поста 1 - результат вставляется в столбец G.
Если данных много, то макрос будет медленно работать, т.к. в ячейках, в которых есть подстрочные символы, анализируется каждый символ, а это очень медленно.
[vba]
Код
Sub Макрос()

    Dim arrSrc()
    Dim lr As Long, i As Long, j As Long, charSrc As Long, charRes As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("G").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    If lr > 1 Then
        Range("G2:G" & lr).Value = Empty
    End If
    
    lr = Columns("A:D").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:D" & lr)
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        Cells(i, "G").Value = arrSrc(i, 1) & arrSrc(i, 2) & arrSrc(i, 3) & arrSrc(i, 4)
        For j = 1 To 4
            If IsNull(Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        Cells(i, "G").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
            Else
                charRes = charRes + Cells(i, j).Characters.Count
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]




Сообщение отредактировал Karataev - Четверг, 11.08.2016, 16:57
 
Ответить
СообщениеМакрос сделан для файла из поста 1 - результат вставляется в столбец G.
Если данных много, то макрос будет медленно работать, т.к. в ячейках, в которых есть подстрочные символы, анализируется каждый символ, а это очень медленно.
[vba]
Код
Sub Макрос()

    Dim arrSrc()
    Dim lr As Long, i As Long, j As Long, charSrc As Long, charRes As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("G").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    If lr > 1 Then
        Range("G2:G" & lr).Value = Empty
    End If
    
    lr = Columns("A:D").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:D" & lr)
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        Cells(i, "G").Value = arrSrc(i, 1) & arrSrc(i, 2) & arrSrc(i, 3) & arrSrc(i, 4)
        For j = 1 To 4
            If IsNull(Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        Cells(i, "G").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
            Else
                charRes = charRes + Cells(i, j).Characters.Count
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 11.08.2016 в 16:49
NIC Дата: Четверг, 11.08.2016, 17:32 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, Что то не работает, вставил в исходный текст макрос и ни чего не происходит, не силен в макросах, может что то не так делаю. А соединять должен автоматом при заполнении ячеек?
 
Ответить
СообщениеKarataev, Что то не работает, вставил в исходный текст макрос и ни чего не происходит, не силен в макросах, может что то не так делаю. А соединять должен автоматом при заполнении ячеек?

Автор - NIC
Дата добавления - 11.08.2016 в 17:32
Karataev Дата: Четверг, 11.08.2016, 17:42 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Вставил макрос в файл, макрос запускается кнопкой из G1.
К сообщению приложен файл: 123.xlsm(21Kb)


 
Ответить
СообщениеВставил макрос в файл, макрос запускается кнопкой из G1.

Автор - Karataev
Дата добавления - 11.08.2016 в 17:42
NIC Дата: Пятница, 12.08.2016, 09:17 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, спасибо, работает, наверное надо было сразу спросить, а что нужно добавить в макрос, чтобы были пробелы между содержимым ячеек, а то каша получается? СПАСИБО
 
Ответить
СообщениеKarataev, спасибо, работает, наверное надо было сразу спросить, а что нужно добавить в макрос, чтобы были пробелы между содержимым ячеек, а то каша получается? СПАСИБО

Автор - NIC
Дата добавления - 12.08.2016 в 09:17
Karataev Дата: Пятница, 12.08.2016, 09:46 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
[vba]
Код
Sub Соединить()

    Dim arrSrc()
    Dim lr As Long, i As Long, j As Long, charSrc As Long, charRes As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("G").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    If lr > 1 Then
        Range("G2:G" & lr).Value = Empty
    End If
    
    lr = Columns("A:D").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:D" & lr)
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        Cells(i, "G").Value = arrSrc(i, 1) & " " & arrSrc(i, 2) & " " & arrSrc(i, 3) & " " & arrSrc(i, 4)
        For j = 1 To 4
            If IsNull(Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        Cells(i, "G").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
                charRes = charRes + 1
            Else
                charRes = charRes + Cells(i, j).Characters.Count + 1
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]


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

    Dim arrSrc()
    Dim lr As Long, i As Long, j As Long, charSrc As Long, charRes As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("G").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    If lr > 1 Then
        Range("G2:G" & lr).Value = Empty
    End If
    
    lr = Columns("A:D").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:D" & lr)
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        Cells(i, "G").Value = arrSrc(i, 1) & " " & arrSrc(i, 2) & " " & arrSrc(i, 3) & " " & arrSrc(i, 4)
        For j = 1 To 4
            If IsNull(Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        Cells(i, "G").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
                charRes = charRes + 1
            Else
                charRes = charRes + Cells(i, j).Characters.Count + 1
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 12.08.2016 в 09:46
NIC Дата: Среда, 17.08.2016, 13:04 | Сообщение № 8
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, Спасибо, ещё вопрос. А что нужно в этом коде заменить, если мне нужно будет соеденить ячейки из 5 или 6 и более столбцов. Сам сижу ковыряю, никак не получается. СПАСИБО
 
Ответить
СообщениеKarataev, Спасибо, ещё вопрос. А что нужно в этом коде заменить, если мне нужно будет соеденить ячейки из 5 или 6 и более столбцов. Сам сижу ковыряю, никак не получается. СПАСИБО

Автор - NIC
Дата добавления - 17.08.2016 в 13:04
Karataev Дата: Среда, 17.08.2016, 13:12 | Сообщение № 9
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Результат нужно обязательно выводить справа от данных? Или можно создать новый пустой лист и вставить результат в столбец A?
Если вставлять справа, то нужно как-то понять, является ли последний столбец данными или результатом от предыдущего запуска макроса. Можно в этом случае по заголовку ориентироваться - макрос будет вставлять какой-нибудь заголовок.


 
Ответить
СообщениеРезультат нужно обязательно выводить справа от данных? Или можно создать новый пустой лист и вставить результат в столбец A?
Если вставлять справа, то нужно как-то понять, является ли последний столбец данными или результатом от предыдущего запуска макроса. Можно в этом случае по заголовку ориентироваться - макрос будет вставлять какой-нибудь заголовок.

Автор - Karataev
Дата добавления - 17.08.2016 в 13:12
NIC Дата: Среда, 17.08.2016, 13:19 | Сообщение № 10
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, результат можно выводить на другой лист в книге, но главное чтобы была возможность добавлять столбы и соединять их в одну ячейку, я так понимаю можно сделать лист, в котором будет соединена вся строка, из ячеек содержащий текст!?
 
Ответить
СообщениеKarataev, результат можно выводить на другой лист в книге, но главное чтобы была возможность добавлять столбы и соединять их в одну ячейку, я так понимаю можно сделать лист, в котором будет соединена вся строка, из ячеек содержащий текст!?

Автор - NIC
Дата добавления - 17.08.2016 в 13:19
Karataev Дата: Среда, 17.08.2016, 13:40 | Сообщение № 11
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Т.к. данные нужно объединять не из всех столбцов (в файле примере в конце два столбца, не участвующих в объединении), то тогда такой вариант - после запуска макроса укажите количество столбцов, начиная со столбца "A", которые надо объединить.
[vba]
Код
Sub Соединить()

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet, arrRes()
    Dim lr As Long, lc, var
    Dim i As Long, j As Long, charSrc As Long, charRes As Long
    
    
    lc = InputBox("Укажите количество столбцов, которые надо объединить:")
    If lc = "" Then
        Exit Sub
    End If
    lc = CLng(lc)
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Columns("A").Resize(, lc).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        var = Empty
        For j = 1 To UBound(arrSrc, 2)
            var = var & arrSrc(i, j)
        Next
        shRes.Cells(i, "A").Value = var
        For j = 1 To UBound(arrSrc, 2)
            If IsNull(shSrc.Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To shSrc.Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If shSrc.Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        shRes.Cells(i, "A").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
            Else
                charRes = charRes + shSrc.Cells(i, j).Characters.Count
            End If
        Next
    Next
    
    shRes.Range("A1").Value = "Результат"
    shRes.Range("A1").Font.Bold = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]


 
Ответить
СообщениеТ.к. данные нужно объединять не из всех столбцов (в файле примере в конце два столбца, не участвующих в объединении), то тогда такой вариант - после запуска макроса укажите количество столбцов, начиная со столбца "A", которые надо объединить.
[vba]
Код
Sub Соединить()

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet, arrRes()
    Dim lr As Long, lc, var
    Dim i As Long, j As Long, charSrc As Long, charRes As Long
    
    
    lc = InputBox("Укажите количество столбцов, которые надо объединить:")
    If lc = "" Then
        Exit Sub
    End If
    lc = CLng(lc)
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Columns("A").Resize(, lc).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    For i = 2 To UBound(arrSrc)
        charRes = 0
        var = Empty
        For j = 1 To UBound(arrSrc, 2)
            var = var & arrSrc(i, j)
        Next
        shRes.Cells(i, "A").Value = var
        For j = 1 To UBound(arrSrc, 2)
            If IsNull(shSrc.Cells(i, j).Font.Subscript) = True Then
                For charSrc = 1 To shSrc.Cells(i, j).Characters.Count
                    charRes = charRes + 1
                    If shSrc.Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                        shRes.Cells(i, "A").Characters(charRes, 1).Font.Subscript = True
                    End If
                Next
            Else
                charRes = charRes + shSrc.Cells(i, j).Characters.Count
            End If
        Next
    Next
    
    shRes.Range("A1").Value = "Результат"
    shRes.Range("A1").Font.Bold = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 17.08.2016 в 13:40
NIC Дата: Среда, 17.08.2016, 13:58 | Сообщение № 12
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, Выдаёт ошибку в строке "charRes = charRes + shSrc.Cells(i, j).Characters.Count"!? только если более 4 столбцов!!!(((
 
Ответить
СообщениеKarataev, Выдаёт ошибку в строке "charRes = charRes + shSrc.Cells(i, j).Characters.Count"!? только если более 4 столбцов!!!(((

Автор - NIC
Дата добавления - 17.08.2016 в 13:58
Karataev Дата: Среда, 17.08.2016, 14:00 | Сообщение № 13
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Указывать нужно только столбцы, которые участвуют в объединении, Вы наверное указали еще и столбцы с числами, которые находятся в файле примере в конце. Ошибка возникает, если в ячейке находится нетекст.


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

Автор - Karataev
Дата добавления - 17.08.2016 в 14:00
NIC Дата: Среда, 17.08.2016, 14:10 | Сообщение № 14
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, Цифры тоже необходимо сцепить. а пробела между ячейками опять нет.
 
Ответить
СообщениеKarataev, Цифры тоже необходимо сцепить. а пробела между ячейками опять нет.

Автор - NIC
Дата добавления - 17.08.2016 в 14:10
Karataev Дата: Среда, 17.08.2016, 14:16 | Сообщение № 15
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
Все столбцы надо сцепливать или какие-то не надо? Например, изначально в Вашем задании надо было сцепить из шести столбцов только первые четыре.


 
Ответить
СообщениеВсе столбцы надо сцепливать или какие-то не надо? Например, изначально в Вашем задании надо было сцепить из шести столбцов только первые четыре.

Автор - Karataev
Дата добавления - 17.08.2016 в 14:16
NIC Дата: Среда, 17.08.2016, 16:02 | Сообщение № 16
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Нет нужно сцеплять все шесть. Они могут быть и с цифрами и с символами.
 
Ответить
СообщениеНет нужно сцеплять все шесть. Они могут быть и с цифрами и с символами.

Автор - NIC
Дата добавления - 17.08.2016 в 16:02
Karataev Дата: Среда, 17.08.2016, 17:00 | Сообщение № 17
Группа: Проверенные
Ранг: Ветеран
Сообщений: 641
Репутация: 226 ±
Замечаний: 0% ±

Excel
[vba]
Код
Sub Соединить()

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet, arrRes()
    Dim lr As Long, lc As Long, var
    Dim i As Long, j As Long, charSrc As Long, charRes As Long
    
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.UsedRange.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    lc = shSrc.UsedRange.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    For i = 2 To UBound(arrSrc)
    
        charRes = 0
        var = Empty
        
        For j = 1 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> Empty Then
                var = var & arrSrc(i, j) & " "
            End If
        Next
        var = Left(var, Len(var) - 1)
        shRes.Cells(i, "A").Value = var
        
        For j = 1 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> Empty Then
                If IsNull(shSrc.Cells(i, j).Font.Subscript) = True Then
                    For charSrc = 1 To shSrc.Cells(i, j).Characters.Count
                        charRes = charRes + 1
                        If shSrc.Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                            shRes.Cells(i, "A").Characters(charRes, 1).Font.Subscript = True
                        End If
                    Next
                Else
                    charRes = charRes + Len(CStr(shSrc.Cells(i, j).Value)) + 1
                End If
            End If
        Next
    Next
    
    shRes.Range("A1").Value = "Результат"
    shRes.Range("A1").Font.Bold = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]


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

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet, arrRes()
    Dim lr As Long, lc As Long, var
    Dim i As Long, j As Long, charSrc As Long, charRes As Long
    
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.UsedRange.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    lc = shSrc.UsedRange.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    For i = 2 To UBound(arrSrc)
    
        charRes = 0
        var = Empty
        
        For j = 1 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> Empty Then
                var = var & arrSrc(i, j) & " "
            End If
        Next
        var = Left(var, Len(var) - 1)
        shRes.Cells(i, "A").Value = var
        
        For j = 1 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> Empty Then
                If IsNull(shSrc.Cells(i, j).Font.Subscript) = True Then
                    For charSrc = 1 To shSrc.Cells(i, j).Characters.Count
                        charRes = charRes + 1
                        If shSrc.Cells(i, j).Characters(charSrc, 1).Font.Subscript = True Then
                            shRes.Cells(i, "A").Characters(charRes, 1).Font.Subscript = True
                        End If
                    Next
                Else
                    charRes = charRes + Len(CStr(shSrc.Cells(i, j).Value)) + 1
                End If
            End If
        Next
    Next
    
    shRes.Range("A1").Value = "Результат"
    shRes.Range("A1").Font.Bold = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 17.08.2016 в 17:00
NIC Дата: Среда, 17.08.2016, 17:56 | Сообщение № 18
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 0% ±

Karataev, СПАСИБО, работает, Думаю тему можно, закрывать.
 
Ответить
СообщениеKarataev, СПАСИБО, работает, Думаю тему можно, закрывать.

Автор - NIC
Дата добавления - 17.08.2016 в 17:56
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Сцепить ячейки с сохранение подстрочных букв (Формулы/Formulas)
Страница 1 из 11
Поиск:

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