Добрый день!
В книге есть несколько столбцов с картинками. Картинки в одном столбце (изображение продукции) не нужно трогать, а в 3-х других (это пиктограммы) - картинкам необходимо назначать размеры и выравнивать по вертикали.
В данный момент для этих целей используются 3 однотипных макроса (которые отличаются друг от друга только указанным номером столбца - 1,6,7), каждый из которых выравнивает по вертикали и назначает размеры картинкам в своем столбце. (это сделано чтобы избежать деформации пиктограмм по причине изменения высоты строк)
Поскольку макросы выравнивают картинки по очереди, сначала один макрос - в своем столбце, потом другой.. т.д. за цикл то на обработку таблицы из 1000 строк уходит больше 5 минут.
Подскажите пожалуйста, как объединить 3 макроса в один, чтобы выравнивались картинки только в столбцах с пиктограммами, возможно это ускорит обработку.
Ниже макросы:
| Код |
|---|
Sub Иконки()
Dim Shp As Shape
Dim Picture As Object
Dim lRow As Long
For lRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Rows(lRow).EntireRow.Hidden = False Then
Dim ra As Range: Set ra = Cells(lRow, 1)
For Each Shp In ShapesInRange(ra)
With Shp
If .Type = msoPicture Then
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
.LockAspectRatio = msoFalse
.Height = 18
.Width = 18
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
End If
End With
Next Shp
End If
Next lRow
End Sub |
| Код |
|---|
Sub Опции()
Dim Shp As Shape
Dim Picture As Object
Dim lRow As Long
For lRow = 2 To Cells(Rows.Count, 7).End(xlUp).Row
If Rows(lRow).EntireRow.Hidden = False Then
Dim ra As Range: Set ra = Cells(lRow, 7)
For Each Shp In ShapesInRange(ra)
With Shp
If .Type = msoPicture Then
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
.LockAspectRatio = msoFalse
.Height = 18
.Width = 18
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
End If
End With
Next Shp
End If
Next lRow
End Sub |
| Код |
|---|
Sub Размеры()
Dim Shp As Shape
Dim Picture As Object
Dim lRow As Long
For lRow = 2 To Cells(Rows.Count, 6).End(xlUp).Row
If Rows(lRow).EntireRow.Hidden = False Then
Dim ra As Range: Set ra = Cells(lRow, 6)
For Each Shp In ShapesInRange(ra)
With Shp
If .Type = msoPicture Then
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
.LockAspectRatio = msoFalse
.Height = 18
.Width = 18
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
End If
End With
Next Shp
End If
Next lRow
End Sub |
как раз из-за картинок.. даже если почти все удалить.. можно Вам по почте тогда отправить?
можете какой-нибудь пример кода привести? я бы попытался его под себя адаптировать.
