Здравствуйте! Прошу помочь с правкой макроса (файл во вложении).
Сейчас кнопка автоподбора работает так: 1) щелкнуть на любую ячейку строки которую надо автоподобрать по высоте 2) выделить диапазон ячеек, строки которых надо автоподобрать по высоте
Требуется: 1) Отредактировать макрос так, чтобы работало в пределах определенного диапазона ячеек или строк (или нескольких диапазонов ячеек или строк), потому что при выделении всего листа атоподбор тратит много ресурсов процессора (щелкнуть на кнопку автоподбор - происходит автоподбор в пределах ячеек D5:R15 или строк 5:15, строк наверно разумнее.. )
Заранее благодарю!
Здравствуйте! Прошу помочь с правкой макроса (файл во вложении).
Сейчас кнопка автоподбора работает так: 1) щелкнуть на любую ячейку строки которую надо автоподобрать по высоте 2) выделить диапазон ячеек, строки которых надо автоподобрать по высоте
Требуется: 1) Отредактировать макрос так, чтобы работало в пределах определенного диапазона ячеек или строк (или нескольких диапазонов ячеек или строк), потому что при выделении всего листа атоподбор тратит много ресурсов процессора (щелкнуть на кнопку автоподбор - происходит автоподбор в пределах ячеек D5:R15 или строк 5:15, строк наверно разумнее.. )
cmivadwot, Ваша кнопка Вариант работает неправильно, очень долго, в итоге смещает столбцы. Моя кнопка работает быстрее и правильнее. Мой вопрос открыт.
cmivadwot, Ваша кнопка Вариант работает неправильно, очень долго, в итоге смещает столбцы. Моя кнопка работает быстрее и правильнее. Мой вопрос открыт.174dom
Сообщение отредактировал 174dom - Четверг, 06.10.2022, 12:55
174dom, Моя кнопка работает со всем листом и так как я ее настроил (записал макрос с манипуляциями которые делал сам (выделил весь лист, убрал объединение ячеек нажав на кнопку... переместил все в лево, расширил столбец, установил формат листа А4 одна страница на много стр))), поставил в ячейке свойства ..переносить по словам - выделив лист щелкнул межстрочье - остановил макрос..) ну и было много лишних действий ..как изменение масштаба просмотра. примерно так). И я не удивлен, что не получилось как нужно вам)))) Вам нужно - открыть свой документ - зайти во вкладку разработчик - нажать запись макроса - сделать все манипуляции необходимые ВАМ- остановить макрос - создать кнопку - привязать макрос. До автоматизации руками делали? Если такой вариант не устраивает... то да.. вопрос открыт
174dom, Моя кнопка работает со всем листом и так как я ее настроил (записал макрос с манипуляциями которые делал сам (выделил весь лист, убрал объединение ячеек нажав на кнопку... переместил все в лево, расширил столбец, установил формат листа А4 одна страница на много стр))), поставил в ячейке свойства ..переносить по словам - выделив лист щелкнул межстрочье - остановил макрос..) ну и было много лишних действий ..как изменение масштаба просмотра. примерно так). И я не удивлен, что не получилось как нужно вам)))) Вам нужно - открыть свой документ - зайти во вкладку разработчик - нажать запись макроса - сделать все манипуляции необходимые ВАМ- остановить макрос - создать кнопку - привязать макрос. До автоматизации руками делали? Если такой вариант не устраивает... то да.. вопрос открытcmivadwot
MikeVol, Спасибо Вам огромное, да, это работает как надо. Имею наглость спросить такой момент: Реально ли в макросе указать адреса двух ячеек, в первой - номер строки с которой начинается автоподбор, во второй - номер строки до которой надо подбирать Например на листе есть две ячейки, в одной цифра 2, в другой цифра 15. Кнопка автоподбор будет запускать макрос, макрос соответственно будет обращаться к этим двум ячейкам и подбирать по высоте заданные строки ?
MikeVol, Спасибо Вам огромное, да, это работает как надо. Имею наглость спросить такой момент: Реально ли в макросе указать адреса двух ячеек, в первой - номер строки с которой начинается автоподбор, во второй - номер строки до которой надо подбирать Например на листе есть две ячейки, в одной цифра 2, в другой цифра 15. Кнопка автоподбор будет запускать макрос, макрос соответственно будет обращаться к этим двум ячейкам и подбирать по высоте заданные строки ?174dom
Private Type Box: Hdn As Boolean: Hght As Single: End Type Public Sub AutoH() Dim j&, q&, f&, l&, fr&, lr&, cWh!, rHh!, i() As Box, clwdth() As Single, x As Object Application.ScreenUpdating = False On Error Resume Next With ActiveSheet Dim Start$, Finish$ Start = Range("I1") Finish = Range("J1") For Each x In Rows(Start & ":" & Finish) x.EntireRow.AutoFit Set x = IIf(x.Address = .Rows.Address Or x.Address = .Columns(x.Column).Address, .UsedRange, _ .Range(.Cells(x.Row, .UsedRange.Column), .Cells(x.Rows.Count + x.Row - 1, .UsedRange.Columns.Count + .UsedRange.Column - 1))) ReDim clwdth(x.Column To x.Column + x.Columns.Count - 1): fr = x.Row: lr = x.Rows.Count + x.Row - 1: ReDim i(fr To lr) For j = x.Column To x.Column + x.Columns.Count - 1: clwdth(j) = .Columns(j).ColumnWidth: Next For j = lr To fr Step -1 Set x = .Rows(j): i(j).Hdn = x.Hidden: x.AutoFit: i(j).Hght = x.RowHeight For l = .UsedRange.Column To .UsedRange.Column + .UsedRange.Columns.Count - 1 If .Cells(j, l).MergeCells Then With .Cells(j, l).MergeArea If ActiveSheet.Cells(j, l).Address = .Item(1).Address Then For q = .Column To .Columns.Count + .Column - 1: cWh = cWh + clwdth(q) + 0.647: Next If cWh > 255 Then cWh = 0: GoTo L1 For q = .Row To .Row + .Rows.Count - 1 If Not i(q).Hdn Then rHh = rHh + i(q).Hght: If f = 0 Then f = q Next .UnMerge: .Item(1).ColumnWidth = cWh: x.AutoFit: rHh = x.RowHeight - (rHh - i(f).Hght) If f <> j Then If i(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh .Merge: .Item(1).ColumnWidth = clwdth(.Column) If i(f).Hght < rHh Then i(f).Hght = rHh cWh = 0: rHh = 0: f = 0 End If End With End If L1: Next If i(j).Hght > 0 Then x.RowHeight = i(j).Hght If i(j).Hdn Then x.Hidden = True Next Next End With End Sub
[/vba]
Резюме: 1) + Все прекрасно работает. 2) + Значения начальной и конечной строки в моем варианте указываются в ячейках I1, J1. 3) - Долго обрабатывает 100 строк, это печально...
Конечно же вопрос: возможна ли оптимизация данного макроса для более быстрой работоспособности (обработки) этого чуда?
Serge_007, Спасибо огромное, все получилось!
В итоге получился такой макрос:
[vba]
Код
Private Type Box: Hdn As Boolean: Hght As Single: End Type Public Sub AutoH() Dim j&, q&, f&, l&, fr&, lr&, cWh!, rHh!, i() As Box, clwdth() As Single, x As Object Application.ScreenUpdating = False On Error Resume Next With ActiveSheet Dim Start$, Finish$ Start = Range("I1") Finish = Range("J1") For Each x In Rows(Start & ":" & Finish) x.EntireRow.AutoFit Set x = IIf(x.Address = .Rows.Address Or x.Address = .Columns(x.Column).Address, .UsedRange, _ .Range(.Cells(x.Row, .UsedRange.Column), .Cells(x.Rows.Count + x.Row - 1, .UsedRange.Columns.Count + .UsedRange.Column - 1))) ReDim clwdth(x.Column To x.Column + x.Columns.Count - 1): fr = x.Row: lr = x.Rows.Count + x.Row - 1: ReDim i(fr To lr) For j = x.Column To x.Column + x.Columns.Count - 1: clwdth(j) = .Columns(j).ColumnWidth: Next For j = lr To fr Step -1 Set x = .Rows(j): i(j).Hdn = x.Hidden: x.AutoFit: i(j).Hght = x.RowHeight For l = .UsedRange.Column To .UsedRange.Column + .UsedRange.Columns.Count - 1 If .Cells(j, l).MergeCells Then With .Cells(j, l).MergeArea If ActiveSheet.Cells(j, l).Address = .Item(1).Address Then For q = .Column To .Columns.Count + .Column - 1: cWh = cWh + clwdth(q) + 0.647: Next If cWh > 255 Then cWh = 0: GoTo L1 For q = .Row To .Row + .Rows.Count - 1 If Not i(q).Hdn Then rHh = rHh + i(q).Hght: If f = 0 Then f = q Next .UnMerge: .Item(1).ColumnWidth = cWh: x.AutoFit: rHh = x.RowHeight - (rHh - i(f).Hght) If f <> j Then If i(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh .Merge: .Item(1).ColumnWidth = clwdth(.Column) If i(f).Hght < rHh Then i(f).Hght = rHh cWh = 0: rHh = 0: f = 0 End If End With End If L1: Next If i(j).Hght > 0 Then x.RowHeight = i(j).Hght If i(j).Hdn Then x.Hidden = True Next Next End With End Sub
[/vba]
Резюме: 1) + Все прекрасно работает. 2) + Значения начальной и конечной строки в моем варианте указываются в ячейках I1, J1. 3) - Долго обрабатывает 100 строк, это печально...
Конечно же вопрос: возможна ли оптимизация данного макроса для более быстрой работоспособности (обработки) этого чуда?174dom
Сообщение отредактировал Serge_007 - Пятница, 07.10.2022, 11:20
В итоге получился такой макрос: Резюме: 1) + Все прекрасно работает. 2) + Значения начальной и конечной строки в моем варианте указываются в ячейках A1, A2. 3) - Долго обрабатывает 100 строк, это печально... 4) Конечно же вопрос: А возможно ли оптимизировать данный макрос для более быстрой работоспособности (обработки)? [vba]
Код
Private Type Box: Hdn As Boolean: Hght As Single: End Type Public Sub Podbor_visoti_A1A2() Dim j&, q&, f&, l&, fr&, lr&, cWh!, rHh!, i() As Box, clwdth() As Single, x As Object Application.ScreenUpdating = False On Error Resume Next With ActiveSheet Dim Start$, Finish$ Start = Range("A1") Finish = Range("A2") For Each x In Rows(Start & ":" & Finish) x.EntireRow.AutoFit Set x = IIf(x.Address = .Rows.Address Or x.Address = .Columns(x.Column).Address, .UsedRange, _ .Range(.Cells(x.Row, .UsedRange.Column), .Cells(x.Rows.Count + x.Row - 1, .UsedRange.Columns.Count + .UsedRange.Column - 1))) ReDim clwdth(x.Column To x.Column + x.Columns.Count - 1): fr = x.Row: lr = x.Rows.Count + x.Row - 1: ReDim i(fr To lr) For j = x.Column To x.Column + x.Columns.Count - 1: clwdth(j) = .Columns(j).ColumnWidth: Next For j = lr To fr Step -1 Set x = .Rows(j): i(j).Hdn = x.Hidden: x.AutoFit: i(j).Hght = x.RowHeight For l = .UsedRange.Column To .UsedRange.Column + .UsedRange.Columns.Count - 1 If .Cells(j, l).MergeCells Then With .Cells(j, l).MergeArea If ActiveSheet.Cells(j, l).Address = .Item(1).Address Then For q = .Column To .Columns.Count + .Column - 1: cWh = cWh + clwdth(q) + 0.647: Next If cWh > 255 Then cWh = 0: GoTo L1 For q = .Row To .Row + .Rows.Count - 1 If Not i(q).Hdn Then rHh = rHh + i(q).Hght: If f = 0 Then f = q Next .UnMerge: .Item(1).ColumnWidth = cWh: x.AutoFit: rHh = x.RowHeight - (rHh - i(f).Hght) If f <> j Then If i(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh .Merge: .Item(1).ColumnWidth = clwdth(.Column) If i(f).Hght < rHh Then i(f).Hght = rHh cWh = 0: rHh = 0: f = 0 End If End With End If L1: Next If i(j).Hght > 0 Then x.RowHeight = i(j).Hght If i(j).Hdn Then x.Hidden = True Next Next End With End Sub
В итоге получился такой макрос: Резюме: 1) + Все прекрасно работает. 2) + Значения начальной и конечной строки в моем варианте указываются в ячейках A1, A2. 3) - Долго обрабатывает 100 строк, это печально... 4) Конечно же вопрос: А возможно ли оптимизировать данный макрос для более быстрой работоспособности (обработки)? [vba]
Код
Private Type Box: Hdn As Boolean: Hght As Single: End Type Public Sub Podbor_visoti_A1A2() Dim j&, q&, f&, l&, fr&, lr&, cWh!, rHh!, i() As Box, clwdth() As Single, x As Object Application.ScreenUpdating = False On Error Resume Next With ActiveSheet Dim Start$, Finish$ Start = Range("A1") Finish = Range("A2") For Each x In Rows(Start & ":" & Finish) x.EntireRow.AutoFit Set x = IIf(x.Address = .Rows.Address Or x.Address = .Columns(x.Column).Address, .UsedRange, _ .Range(.Cells(x.Row, .UsedRange.Column), .Cells(x.Rows.Count + x.Row - 1, .UsedRange.Columns.Count + .UsedRange.Column - 1))) ReDim clwdth(x.Column To x.Column + x.Columns.Count - 1): fr = x.Row: lr = x.Rows.Count + x.Row - 1: ReDim i(fr To lr) For j = x.Column To x.Column + x.Columns.Count - 1: clwdth(j) = .Columns(j).ColumnWidth: Next For j = lr To fr Step -1 Set x = .Rows(j): i(j).Hdn = x.Hidden: x.AutoFit: i(j).Hght = x.RowHeight For l = .UsedRange.Column To .UsedRange.Column + .UsedRange.Columns.Count - 1 If .Cells(j, l).MergeCells Then With .Cells(j, l).MergeArea If ActiveSheet.Cells(j, l).Address = .Item(1).Address Then For q = .Column To .Columns.Count + .Column - 1: cWh = cWh + clwdth(q) + 0.647: Next If cWh > 255 Then cWh = 0: GoTo L1 For q = .Row To .Row + .Rows.Count - 1 If Not i(q).Hdn Then rHh = rHh + i(q).Hght: If f = 0 Then f = q Next .UnMerge: .Item(1).ColumnWidth = cWh: x.AutoFit: rHh = x.RowHeight - (rHh - i(f).Hght) If f <> j Then If i(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh .Merge: .Item(1).ColumnWidth = clwdth(.Column) If i(f).Hght < rHh Then i(f).Hght = rHh cWh = 0: rHh = 0: f = 0 End If End With End If L1: Next If i(j).Hght > 0 Then x.RowHeight = i(j).Hght If i(j).Hdn Then x.Hidden = True Next Next End With End Sub
174dom, что происходит после расширения строк? печатается? или еще что? и почему именно выделенные строки должны расширяться? Прикладываю примитивный, хитрый вариант (если задача только в автоподборе высоты и сохранении ширины столбца) на одновременное форматирование 1000 строк за пару сек)))) надо только прикрутить будет еще кнопку очистки...
174dom, что происходит после расширения строк? печатается? или еще что? и почему именно выделенные строки должны расширяться? Прикладываю примитивный, хитрый вариант (если задача только в автоподборе высоты и сохранении ширины столбца) на одновременное форматирование 1000 строк за пару сек)))) надо только прикрутить будет еще кнопку очистки...cmivadwot
174dom, ну и без макроса, со скрытым столбцом (AT), ячейки которого равны ячейкам оригинала, шириной как объединенные ячейки оригинала с форматированием ячейки - переносить по словам. расширение строки классическим способом выделить строку(строки) и двойной щелчок на стык.
174dom, ну и без макроса, со скрытым столбцом (AT), ячейки которого равны ячейкам оригинала, шириной как объединенные ячейки оригинала с форматированием ячейки - переносить по словам. расширение строки классическим способом выделить строку(строки) и двойной щелчок на стык.cmivadwot
Необычное решение, позвольте задам вопрос: 1) Каким образом подбирается точная ширина столбца AT - только через настройку на вкладке Вид - Разметка страницы - далее настроить ширину вручную задав мм? - в принципе можно заморочиться, это не долго. Резюмирую: Работает действительно моментально быстро. У меня такого плана в голове конечно же за много лет не созрело Спасибо! Попробую сей метод применить. Но стоит заметить, что при внедрении строк - формулы в столбце AT полетят.
Необычное решение, позвольте задам вопрос: 1) Каким образом подбирается точная ширина столбца AT - только через настройку на вкладке Вид - Разметка страницы - далее настроить ширину вручную задав мм? - в принципе можно заморочиться, это не долго. Резюмирую: Работает действительно моментально быстро. У меня такого плана в голове конечно же за много лет не созрело Спасибо! Попробую сей метод применить. Но стоит заметить, что при внедрении строк - формулы в столбце AT полетят.174dom
Сообщение отредактировал Serge_007 - Понедельник, 10.10.2022, 10:00
174dom, я ширину столбца АТ брал на глазок (раздвинув ваш первый столбец до окончания последнего) потом посмотрел сколько получилась ширина и этот размер задал в АТ. а столбце АТ записал , что ячейка АТ5 написал =D5, протянул формулу вниз. установил формат - переносить по словам. выделил столбец АТ - нажал скрыть.
"Но стоит заметить, что при внедрении строк - формулы в столбце AT полетят." по какой причине это произойдет? если в АТ5.6.7.8... =D5,6,7.8.... если информация просто вставляется в столбец d то все должно работать. Так как количество текста будет в одной ячейке меняться, выделение и двойной шелчек убедт уменьшать либо раздвигать строки. Я не знаю что там происходит еще)))) есди будет автоматом удалятся наверно можно макрос записать расширяющий столбец, изменяющий формат ячейки и скрывающий столбец. да работает... записал. прикрепляю, можно еще дописать чтоб выделяло все строки и расширяло всё.
174dom, я ширину столбца АТ брал на глазок (раздвинув ваш первый столбец до окончания последнего) потом посмотрел сколько получилась ширина и этот размер задал в АТ. а столбце АТ записал , что ячейка АТ5 написал =D5, протянул формулу вниз. установил формат - переносить по словам. выделил столбец АТ - нажал скрыть.
"Но стоит заметить, что при внедрении строк - формулы в столбце AT полетят." по какой причине это произойдет? если в АТ5.6.7.8... =D5,6,7.8.... если информация просто вставляется в столбец d то все должно работать. Так как количество текста будет в одной ячейке меняться, выделение и двойной шелчек убедт уменьшать либо раздвигать строки. Я не знаю что там происходит еще)))) есди будет автоматом удалятся наверно можно макрос записать расширяющий столбец, изменяющий формат ячейки и скрывающий столбец. да работает... записал. прикрепляю, можно еще дописать чтоб выделяло все строки и расширяло всё.cmivadwot
174dom, полный цикл: Создает АТ шириной=29,67, прописывает АТ5=D5, протягивает формулу до =d1011, меняет формат ячейки- переносить по словам, скрывает столбец АТ, выделяет весь лист, подбирает высоту
174dom, полный цикл: Создает АТ шириной=29,67, прописывает АТ5=D5, протягивает формулу до =d1011, меняет формат ячейки- переносить по словам, скрывает столбец АТ, выделяет весь лист, подбирает высотуcmivadwot
1) Каким образом подбирается точная ширина столбца AT - только через настройку на вкладке Вид - Разметка страницы - далее настроить ширину вручную задав мм? - в принципе можно заморочиться, это не долго.
на названии столбца правой кнопкой мыши - найти ширина столбца..- и вводим, какой размер чему соответствует в мм или дюймах не помню, надо смотреть, там что то по строкам и столбцам вроде разное было.
1) Каким образом подбирается точная ширина столбца AT - только через настройку на вкладке Вид - Разметка страницы - далее настроить ширину вручную задав мм? - в принципе можно заморочиться, это не долго.
на названии столбца правой кнопкой мыши - найти ширина столбца..- и вводим, какой размер чему соответствует в мм или дюймах не помню, надо смотреть, там что то по строкам и столбцам вроде разное было.cmivadwot
Сообщение отредактировал cmivadwot - Понедельник, 10.10.2022, 14:45
ну и без макроса, со скрытым столбцом (AT), ячейки которого равны ячейкам оригинала, шириной как объединенные ячейки оригинала с форматированием ячейки - переносить по словам. расширение строки классическим способом выделить строку(строки) и двойной щелчок на стык.
Ушел вообще от макроса (хотя макрос прекрасно работает) потому что скорость обработки слишком низкая. В итоге я создал копию столбца, скрыл его, подбор работает моментально. Однако столкнулся с тем, что при определенных условиях раскрывается высота строки недостаточно, при этом содержание ячейки 5 строк 10ым шрифтом с числами и словами (примерно 370 символов), правильно должно быть 5 строк, расширяет до 4 строк, и пару слов обрезает в видимом диапазоне и конечно же при печати... - это явление происходит и при макросе и при данном методе... Скорее это косяк самого excel. Самое что неприятное, после редактирования ячейки (например убрать 1 символ и обратно его вписать) кликаем enter, затем щелкаем между строк (автоподбор) - делает 5 строк, при повторном щелканье между тех же строк - делает 4 строки, почему - не понимаю... Это можно повторять вечно. Парадокс )))
RAN, Конечно же нет, такой оптимизации не надо. cmivadwot, Спасибо за совет
ну и без макроса, со скрытым столбцом (AT), ячейки которого равны ячейкам оригинала, шириной как объединенные ячейки оригинала с форматированием ячейки - переносить по словам. расширение строки классическим способом выделить строку(строки) и двойной щелчок на стык.
Ушел вообще от макроса (хотя макрос прекрасно работает) потому что скорость обработки слишком низкая. В итоге я создал копию столбца, скрыл его, подбор работает моментально. Однако столкнулся с тем, что при определенных условиях раскрывается высота строки недостаточно, при этом содержание ячейки 5 строк 10ым шрифтом с числами и словами (примерно 370 символов), правильно должно быть 5 строк, расширяет до 4 строк, и пару слов обрезает в видимом диапазоне и конечно же при печати... - это явление происходит и при макросе и при данном методе... Скорее это косяк самого excel. Самое что неприятное, после редактирования ячейки (например убрать 1 символ и обратно его вписать) кликаем enter, затем щелкаем между строк (автоподбор) - делает 5 строк, при повторном щелканье между тех же строк - делает 4 строки, почему - не понимаю... Это можно повторять вечно. Парадокс )))174dom