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

Регистрация

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

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

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по Excel » Сцепить ячейки с сохранение подстрочных букв (Формулы/Formulas)

Сцепить ячейки с сохранение подстрочных букв

Дата: Четверг, 11.08.2016, 15:15 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

Доброго дня. Столкнулся с проблемой. Есть необходимость сцепить ячейки с сохранением форматирования, а именно подстрочных букв. Формула сцепить, как понял, для этого бесполезна. Прошу помочь решить задачу. В макросах не очень разбираюсь. Спасибо.

К сообщению приложен файл: 123.xlsx (11.2 Kb)

Ответить

Дата: Четверг, 11.08.2016, 16:44 | Сообщение № 2

Группа: Друзья

Ранг: Старожил

Сообщений: 1588

Репутация: 192 ±

Замечаний: 0% ±

Excel 2016 х 64

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

вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com

Ответить

Дата: Четверг, 11.08.2016, 16:49 | Сообщение № 3

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 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]

Макрос сделан для файла из поста 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

Сообщение отредактировал 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

Дата: Четверг, 11.08.2016, 17:32 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Четверг, 11.08.2016, 17:42 | Сообщение № 5

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 0% ±

Excel

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

К сообщению приложен файл: 123.xlsm (21.0 Kb)

Ответить

Дата: Пятница, 12.08.2016, 09:17 | Сообщение № 6

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Пятница, 12.08.2016, 09:46 | Сообщение № 7

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 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]

Ответить

Дата: Среда, 17.08.2016, 13:04 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Среда, 17.08.2016, 13:12 | Сообщение № 9

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 0% ±

Excel

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

Ответить

Дата: Среда, 17.08.2016, 13:19 | Сообщение № 10

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Среда, 17.08.2016, 13:40 | Сообщение № 11

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 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

Ответить

СообщениеТ.к. данные нужно объединять не из всех столбцов (в файле примере в конце два столбца, не участвующих в объединении), то тогда такой вариант - после запуска макроса укажите количество столбцов, начиная со столбца "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

Дата: Среда, 17.08.2016, 13:58 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Среда, 17.08.2016, 14:00 | Сообщение № 13

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 0% ±

Excel

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

Ответить

Дата: Среда, 17.08.2016, 14:10 | Сообщение № 14

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Среда, 17.08.2016, 14:16 | Сообщение № 15

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 0% ±

Excel

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

Ответить

Дата: Среда, 17.08.2016, 16:02 | Сообщение № 16

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Дата: Среда, 17.08.2016, 17:00 | Сообщение № 17

Группа: Проверенные

Ранг: Старожил

Сообщений: 1334

Репутация: 533 ±

Замечаний: 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]

Код

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

Дата: Среда, 17.08.2016, 17:56 | Сообщение № 18

Группа: Пользователи

Ранг: Участник

Сообщений: 56

Репутация: 0 ±

Замечаний: 0% ±

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

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по Excel » Сцепить ячейки с сохранение подстрочных букв (Формулы/Formulas)

Страница 1 из 1
1

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