Макрос на поиск строк, объединение ячеек, выравнивание

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

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

Макрос на поиск строк, объединение ячеек, выравнивание (Макросы/Sub)

falazure123

Дата: Четверг, 05.11.2020, 10:13 | Сообщение № 1

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

Ранг: Прохожий

Сообщений: 2

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

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

Excel 2019

Добрый день.
Помогите, пожалуйста, с макросом.

Нужно написать макрос, который:
1) идёт по строкам, начиная с 13.
2) выполняет проверку: если столбец B пустой, то объединить ячейки с A по Z, выровнять содержимое по левому краю. (если не очень сложно, то дополнительно у строки сделать толстые внешние границы).
И так для каждой такой найденной строки. (нужно понять как выйти из цикла).

(ну или может можно макрос написать оптимальнее. Не через цикл по строкам, а через поиск и выделение таких строк и дальше объединение + выравнивание. Это, наверное, должно быстрее работать, чем цикл).

Во вложении файл, который формируется сейчас - before.xls.
И пример файла, который должен получиться после выполнения макроса - after.xls

К сообщению приложен файл: after.xls (51.0 Kb) · before.xls (50.0 Kb)

Ответить

Hugo

Дата: Четверг, 05.11.2020, 11:06 | Сообщение № 2

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

Ранг: Участник клуба

Сообщений: 3690

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

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

365

Добрый день.
На 3 строки долго не будет, можно даже не отключать обновление экрана.
Вот, используя макрорекордер (обработка в чистом виде запись рекордера, специально ничего не выкидывал, только заменил selection на аргумент):

[vba]

Код

Option Explicit

Sub tt()
    Dim i&, lr&
    lr = Cells(Rows.Count, 26).End(xlUp).Row

    Application.ScreenUpdating = False
    For i = 13 To lr
        If Len(Trim(Cells(i, 2))) = 0 Then
            обработка Cells(i, 1).Resize(, 26)
        End If
    Next
    Application.ScreenUpdating = True

End Sub

Sub обработка(rng)

    With rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    rng.Merge
    With rng
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    rng.Borders(xlDiagonalDown).LineStyle = xlNone
    rng.Borders(xlDiagonalUp).LineStyle = xlNone
    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    rng.Borders(xlInsideVertical).LineStyle = xlNone
    rng.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

[/vba]

[vba]

Код

[/vba]

Hugo

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 05.11.2020, 11:10

Ответить

СообщениеДобрый день.
На 3 строки долго не будет, можно даже не отключать обновление экрана.
Вот, используя макрорекордер (обработка в чистом виде запись рекордера, специально ничего не выкидывал, только заменил selection на аргумент):

[vba]

Код

[/vba]

Автор - Hugo
Дата добавления - 05.11.2020 в 11:06

falazure123

Дата: Четверг, 05.11.2020, 11:15 | Сообщение № 3

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

Ранг: Прохожий

Сообщений: 2

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

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

Excel 2019

Цитата Hugo, 05.11.2020 в 11:06, в сообщении № 2 ()

В том и дело , что строк может быть сколько угодно (выгружаются данные из системы). Это для примера скинул файлы.

Ответить

Nic70y

Дата: Четверг, 05.11.2020, 12:50 | Сообщение № 4

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

Ранг: Экселист

Сообщений: 9005

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

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

Excel 2010

не по тексту
[vba]

Код

Sub u_800()
    Application.ScreenUpdating = False 'отключение обновления экрана
    ua = Cells(Rows.Count, "a").End(xlUp).Row 'последняя заполненная строка столбца A
    If ua > 19 Then 'если есть строки для проверки, выполняем (19 = 12 + 7(итоговые строки))
        ua = ua - 7 'отсекаем итоговые строки
        ub = Application.CountIf(Range("a13:a" & ua), "*") 'считаем кол-во строк с текстом (т.к. остальное числа)
        If ub > 0 Then 'если строки с текстом есть, пройдемся по ним циклом
            uc = 13 'начальная* строка поиска
            For ud = 1 To ub
                ue = Application.Match("*", Range("a" & uc & ":a" & ua), 0) 'ищем строку с текстом
                uf = ue + uc - 1 'номер строки с текстом
                uc = uf + 1 'следующая* строка поиска
                Range("a" & uf & ":z" & uf).Merge 'объединение ячеек в строке
                Range("a" & uf & ":z" & uf).HorizontalAlignment = xlLeft 'по левому краю
                Range("a" & uf & ":z" & uf).Borders(xlEdgeLeft).Weight = xlMedium 'границы
                Range("a" & uf & ":z" & uf).Borders(xlEdgeRight).Weight = xlMedium
                Range("a" & uf & ":z" & uf).Borders(xlEdgeTop).Weight = xlMedium
                Range("a" & uf & ":z" & uf).Borders(xlEdgeBottom).Weight = xlMedium
            Next ud
        End If
    End If
    Application.ScreenUpdating = True 'включение обновления экрана
End Sub

[/vba]

не по тексту
[vba]

Код

[/vba]Nic70y

ЮMoney 41001841029809

Ответить

Сообщениене по тексту
[vba]

Код

[/vba]

Автор - Nic70y
Дата добавления - 05.11.2020 в 12:50

Hugo

Дата: Четверг, 05.11.2020, 20:13 | Сообщение № 5

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

Ранг: Участник клуба

Сообщений: 3690

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

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

365

Можно так ускориться:

[vba]

Код

Option Explicit

Sub tt()
    Dim i&, lr&, ra As Range
    lr = Cells(Rows.Count, 26).End(xlUp).Row

    For i = 13 To lr
        If Len(Trim(Cells(i, 2))) = 0 Then
            If ra Is Nothing Then Set ra = Cells(i, 1).Resize(, 26) Else Set ra = Union(ra, Cells(i, 1).Resize(, 26))
        End If
    Next
    обработка ra
End Sub

Sub обработка(rng)
    With rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    rng.Merge True
    With rng
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    rng.Borders(xlDiagonalDown).LineStyle = xlNone
    rng.Borders(xlDiagonalUp).LineStyle = xlNone
    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    rng.Borders(xlInsideVertical).LineStyle = xlNone
    rng.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

[/vba]

Есть ещё резерв - анализируем/перебираем массив. Ну это заметно сыграет если строк где-то более 10к уже...

Можно так ускориться:

[vba]

Код

[/vba]

Есть ещё резерв - анализируем/перебираем массив. Ну это заметно сыграет если строк где-то более 10к уже...Hugo

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 05.11.2020, 20:14

Ответить

СообщениеМожно так ускориться:

[vba]

Код

[/vba]

Есть ещё резерв - анализируем/перебираем массив. Ну это заметно сыграет если строк где-то более 10к уже...

Автор - Hugo
Дата добавления - 05.11.2020 в 20:13

Макрос на поиск строк, объединение ячеек, выравнивание (Макросы/Sub)

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