Добрый день, Гуру! Прошу помощи. Есть много файлов со вкладками на каждой определённая объединённая ячейка с текстом который не весь виден и при распечатки не виден (в примере это С10,D10). Нужен макрос, который изменит размер заданной ячейки по величине текста при этом во всех листах и книгах находящихся в заданной папке (файлов больше 30). В интернете нашел https://www.sql.ru/forum/155379/excel-avtomaticheskoe-izmenenie-vysoty-stroki-s-obedinennymi-yacheykami но как приспособить не знаю. Огромное спасибо!.
Mike Belov написал: а мне надо для конкретной ячейки и многих файлов
Эти файлы находятся в определенной директории или есть список с файлами, или может выбор должен происходить через диалоговое окно, как Вы определяете в каких файлах Вам нужно это делать? Изменяемая ячейка находится в одном месте или ее нужно искать? Сколько листов в файлах, на всех нужно менять или только на одном?
Огромное спасибо, что откликнулись!! - путь к папке можно в теле макроса прописать (буду менять сам); - менять будем во всех файлах находящихся в папке к которой указан путь; - изменяемая ячейка в одно месте находится; - листов в книгах разное количество, менять нужно во всех.
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
Mike Belov, цитату лучше сразу исправьте ( для ответа достаточно нажать Имя) откуда я могу знать что не так?) у меня все работает - может путь не верный, может файлы имеют другое расширение... еще найдите разницу: моя
Михаил Витальевич С. написал: Mike Belov , вам обязательно нужно объединять C10 и D10?И покажите, что вы хотите видеть в результате.
Да совершенно верно, в результате мне просто нужно расширить объединённую ячейку, чтобы виден был в ней весь текст. По сути это увеличение ячейки по высоте. Это важно.
это что значит? объединение никак нельзя использовать? или никак нельзя убирать? можете нормально написать что есть текст в 2х объеденных ячейках и что бы он был виден полностью вам нужно что? расширить диапазон объеденных ячеек? просто растянуть высоту строки и сделать перенос по строкам ?
Ага. Значит мне необходимо , что бы был перенос по строкам без объединения. У меня в примере два столбца объединены. А бывает, что и 10 (для должности подписанта) поэтому надо, что бы был перенос по строкам и растянуть вниз. Спасибо за терпение.
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
Да, макрос работает. Единственное что нужно в ручную выставлять высоту. Друг подкинул действительно работающий макрос (прилагаю). Единственное прошу его адаптировать к открытию многих файлов и вкладок. Если сможете конечно. Спасибо!
Код
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
Огонь! Спасибо!!! Единственный вопрос в строке наименование должности бывает нужно указать с кавычками "" т.е. "АИИСКУЭ" берём внутри в кавычки или серез тире пишется должность, тогда выдаёт ошибку. Как исправить спасибо!
Код
Tx = "Заместитель директора департамента сопровождения АИИСКУЭ"