Страницы: 1
RSS
Подбор высоты строки по тексту во всех листах книги, Необходимо заданную ячейку выровнять по тексту во всех листах книги (нескольких книгах).
 
Добрый день, Гуру! Прошу помощи.
Есть много файлов со вкладками на каждой определённая объединённая ячейка  с текстом который не весь виден и при распечатки не виден (в примере это С10,D10). Нужен макрос, который изменит размер  заданной ячейки по величине текста при этом во всех листах и книгах находящихся в заданной папке (файлов больше 30).
В интернете нашел https://www.sql.ru/forum/155379/excel-avtomaticheskoe-izmenenie-vysoty-stroki-s-obedinennymi-yacheykami но как приспособить не знаю. Огромное спасибо!.
 
Mike Belov, добрый день. Посмотрите у Дмитрия Щербакова вот ЗДЕСЬ
 
Спасибо, я видел данный макрос, но он работает для выделенной области, а мне надо для конкретной ячейки и многих файлов. Очень прошу помочь!
 
Цитата
Mike Belov написал:
а мне надо для конкретной ячейки и многих файлов
Эти файлы находятся в определенной директории или есть список с файлами, или может выбор должен происходить через диалоговое окно, как Вы определяете в каких файлах Вам нужно это делать? Изменяемая ячейка находится в одном месте или ее нужно искать? Сколько листов в файлах, на всех нужно менять или только на одном?
Изменено: msi2102 - 21.07.2020 14:34:42
 
Огромное спасибо, что откликнулись!!
- путь к папке можно в теле макроса прописать (буду менять сам);
-  менять будем  во всех файлах находящихся в папке к которой указан путь;
- изменяемая ячейка в одно месте находится;
- листов в книгах разное количество, менять нужно во всех.

Очень прошу помочь.
 
Mike Belov, к сожалению сегодня нет времени, если никто не поможет то завтра сделаю
 
Цитата
Mike Belov написал:
который изменит размер  заданной ячейки по величине текста
измените только на свой путь. (взято здесь https://excelpedia.ru/makrosi-v-excel/otkrit-vse-rabochie-knigi)
(а вам уже писали макрос перебора листов книг ...ТУТ да и ваши темы практически состоят в одном и том же с разных файлов всех листов и поехало....)
Код
Sub ddd()
Dim MyFiles As String
Dim oWh As Worksheet
Application.ScreenUpdating = fasle
Application.DisplayAlerts = False
MyFiles = Dir("C:\Users\Новая папка\*.xlsx")

Do While MyFiles <> ""

Workbooks.Open "C:\Users\Новая папка\" & MyFiles

For Each oWh In Worksheets
oWh.Range("C10:D10").MergeCells = False
oWh.Range("C10").WrapText = False
oWh.Columns("C:C").EntireColumn.AutoFit
Next oWh

ActiveWorkbook.Close SaveChanges:=True
MyFiles = Dir
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Изменено: Mershik - 21.07.2020 17:03:30
Не бойтесь совершенства. Вам его не достичь.
 
Спасибо, большое. Только не работает.
Подскажите, что не так.
 
Mike Belov, цитату лучше сразу исправьте ( для ответа достаточно нажать Имя)
откуда я могу знать что не так?) у меня все работает - может путь не верный, может  файлы имеют другое расширение...
еще найдите разницу:
моя
Код
MyFiles = Dir("C:\Users\Новая папка\*.xlsx")
ваша
Код
MyFiles = Dir("C:\Users\titov-ma\Desktop\1*.xlsx")
 
Изменено: Mershik - 21.07.2020 17:38:49
Не бойтесь совершенства. Вам его не достичь.
 
Mike Belov, вам обязательно нужно объединять C10 и D10?
И покажите, что вы хотите видеть в результате.
 
Цитата
Михаил Витальевич С. написал:
И покажите, что вы хотите видеть в результате.
а я решил наугад делать)
Не бойтесь совершенства. Вам его не достичь.
 
Я не экстрасенс, угадывать не умею. :(
 
Цитата
Mershik написал:
а я решил наугад делать)
Супер!!Всё идеально! Только очень прошу мне объединение никак нельзя, можно без него? Спасибо!
 
Цитата
Михаил Витальевич С. написал:
Mike Belov , вам обязательно нужно объединять C10 и D10?И покажите, что вы хотите видеть в результате.
Да совершенно верно, в результате мне просто нужно расширить объединённую ячейку, чтобы виден был в ней весь текст. По сути это увеличение ячейки по высоте. Это важно.
 
Цитата
Mike Belov написал:
мне объединение никак нельзя
это что значит? объединение никак нельзя использовать? или никак нельзя убирать? можете нормально написать что есть текст в 2х объеденных ячейках и что бы он был виден полностью вам нужно что? расширить диапазон объеденных ячеек? просто растянуть высоту строки и сделать перенос по строкам ?
Не бойтесь совершенства. Вам его не достичь.
 
Ага. Значит мне необходимо , что бы был перенос по строкам без объединения. У меня в примере два столбца объединены. А бывает, что и 10 (для должности подписанта) поэтому надо, что бы был перенос по строкам и растянуть вниз. Спасибо за терпение.
 
Mike Belov, хотите получить помощь? ПОКАЖИТЕ НАКОНЕЦ-ТО
Цитата
Михаил Витальевич С. написал:
что вы хотите видеть в результате.
желательно с учетом того что вы говорите (несколько вариантов)
Цитата
в примере два столбца объединены. А бывает, что и 10 (для должности подписанта)
а  еще...подписанты я полагаю по длине разные?
Изменено: Mershik - 21.07.2020 21:32:12
Не бойтесь совершенства. Вам его не достичь.
 
Ок. Вообщем сделал два файла. "Было" и "Стало" после применения макроса. Изменившуюся область залил жёлтым.
 
Цитата
Mike Belov написал:
сделал два файла. "Было" и "Стало"
А лучше в таких случаях делать ОДИН файл, в котором на разных листах показывать ДО и ПОСЛЕ. Зачем заставлять помогающих скачивать два файла?
 
Mike Belov, не идеально но может подойдет
Код
Sub ddd()
Dim MyFiles As String
Dim oWh As Worksheet
Dim rng As Range
Application.ScreenUpdating = fasle
Application.DisplayAlerts = False
MyFiles = Dir("C:\Users\dell\Desktop\Новая папка (2)\*.xlsx")
 
Do While MyFiles <> ""
 
Workbooks.Open "C:\Users\dell\Desktop\Новая папка (2)\" & MyFiles
 
For Each oWh In Worksheets
oWh.Select
Range("C10").Select
Selection.Resize(, 4).Select
Set rng = Selection

rng.MergeCells = False
rng.HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlTop
rng.WrapText = True

rng.Merge
Rows(rng.Row).RowHeight = 40
Next oWh
 
ActiveWorkbook.Close SaveChanges:=True
MyFiles = Dir
Loop
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 21.07.2020 22:10:23
Не бойтесь совершенства. Вам его не достичь.
 
Да, макрос работает. Единственное что нужно в ручную выставлять высоту. Друг подкинул действительно работающий макрос (прилагаю). Единственное прошу его адаптировать к открытию многих файлов и вкладок. Если сможете конечно. Спасибо!
Код
Option Explicit
' этот Range будем изменять
Function rangeName() As String
    rangeName = "M9:R9"
End Function

' обработка кнопки
Private Sub CommandButton1_Click()
    If Range(rangeName()).MergeCells = False Then
        Range(rangeName()).EntireRow.autoFIT
    Else
        Range(rangeName()).RowHeight = MyRowHeight(Range(rangeName()))
    End If
End Sub

' Событие изменения ячейки
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not (Target.Row = Range(rangeName()).Row And Target.Column = Range(rangeName()).Column) Then
        Exit Sub
    End If

    If Range(rangeName()).MergeCells = False Then
        Range(rangeName()).EntireRow.autoFIT
    Else
        Range(rangeName()).RowHeight = MyRowHeight(Range(rangeName()))
    End If
End Sub

' подбор высоты объединенной ячейки
Function MyRowHeight(ByVal MyRange As Range) As Integer

    Dim MyColumnWidth
    Dim MySheets As Worksheet
    Dim cln

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set MySheets = Sheets.Add ' новый лист
    With MySheets
        For Each cln In MyRange.Columns
            MyColumnWidth = MyColumnWidth + cln.Width * 20 ' Суммарная ширина
        Next cln

        If MyColumnWidth > 180 Then
            MyColumnWidth = Round((MyColumnWidth - 75) / 105, 2)
        Else
            MyColumnWidth = Round((MyColumnWidth - 0) / 180, 2)
        End If

        .Cells(1, 1).ColumnWidth = MyColumnWidth ' выставляем ширину расчетной ячейки

        .Cells(1, 1).Value = MyRange.Value
        .Cells(1, 1).Font.Size = MyRange.Font.Size
        .Cells(1, 1).Font.Name = MyRange.Font.Name
        .Cells(1, 1).Font.Bold = MyRange.Font.Bold
        .Cells(1, 1).Font.FontStyle = MyRange.Font.FontStyle
        .Cells(1, 1).Font.Italic = MyRange.Font.Italic
        .Cells(1, 1).WrapText = True

        MyRowHeight = .Rows(1).RowHeight / MyRange.Rows.Count ' высота всех строк внутри Range одинаковая
        .Delete
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Function
Изменено: Mike Belov - 22.07.2020 01:24:01
 
Цитата
Mershik написал:
Application.ScreenUpdating = fasle
Опечатка в 5 строке fasle замените на False
 
Цитата
Mike Belov написал:
Единственное что нужно в ручную выставлять высоту
Вот так можно запустить в цикле макрос Дмитрия Щербакова и ненужно будет выставлять в ручную высоту.  
 
Огонь! Спасибо!!! Единственный вопрос в строке наименование должности бывает нужно указать с кавычками "" т.е. "АИИСКУЭ" берём внутри в кавычки или серез тире пишется должность, тогда выдаёт ошибку. Как исправить спасибо!
Код
Tx = "Заместитель директора департамента сопровождения АИИСКУЭ"
 
Mike Belov, Можно так:
Код
Tx = "Заместитель директора"
не обязательно писать полную фразу

А если у Вас изменяемая ячейка во всех книгах имеет одинаковый адрес то можно вместо:
Код
If Poisk(Tx) <> "" Then RowColHeightForContent importWB.Worksheets(ws.Name).Range(Poisk(Tx)), True: y = y + 1
 просто указать адрес
Код
RowColHeightForContent importWB.Worksheets(ws.Name).Range("C10"), True: y = y + 1
тогда Tx вообще не нужно
Изменено: msi2102 - 22.07.2020 12:19:42
Страницы: 1
Наверх