Вставка картинок в ячейки в соответствии с числовым кодом, приведенным в таблице
Пользователь
Сообщений: Регистрация: 22.04.2018
14.05.2018 18:36:04
Здравствуйте.
Подскажите - как решить следующий вопрос. В таблице T4:U12 напротив чисел - стоят адреса конкретного файла-рисунка. На листе экселя - в случайных местах расставлены числа, совпадающие с числами из таблицы.
Как макросом расставить рисунки из соответствующих адресов, указанных в таблице - по этим ячейкам (так чтобы они растянувшись вписались точно в ячейку) ?
Это новая версия Тетриса ? Пожалуйста, попробуйте:
Код
Option Explicit
Dim sNme$
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sNme = Trim(Target(1).Value)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iPath, fleNme$, cNme$: cNme = Trim(Target(1).Value)
Dim krtn As Shape
If Not Intersect(Target(1), Range("tabris")) Is Nothing Then Exit Sub
'------------------------------------------------------------------------------------------------------------
If sNme <> "" And cNme = "" Then
On Error Resume Next
ActiveSheet.Shapes(sNme).Delete: Exit Sub
On Error GoTo 0
End If
'------------------------------------------------------------------------------------------------------------
'Variant 1a - 'VLookup'
'iPath = Evaluate("VLookup('List3'!" & Target(1).Address & ",'List3'!" & Range("tabris").Address & ", 2, 0)")
'If IsError(iPath) Or iPath = 0 Then Exit Sub
'------------------------------------------------------------------------------------------------------------
'Variant 1b - 'VLookup'
'iPath = Application.VLookup(Target(1).Value, Range("tabris"), 2, 0)
'If IsError(iPath) Or IsEmpty(iPath) Then Exit Sub
'------------------------------------------------------------------------------------------------------------
'Variant 2 - 'Match'
iPath = Application.Match(Target(1).Value, Range("tabris").Columns(1), 0)
If IsError(iPath) Then Exit Sub
iPath = Range("tabris").Cells(Application.Match(Target(1).Value, Range("tabris").Columns(1), 0), 2).Value
If IsEmpty(iPath) Then Exit Sub
'------------------------------------------------------------------------------------------------------------
fleNme = Dir(iPath, vbNormal)
If fleNme = "" Then Exit Sub
'------------------------------------------------------------------------------------------------------------
Set krtn = Me.Shapes.AddPicture(iPath, msoFalse, msoTrue, Target(1).Left, Target(1).Top, Target(1).Width, Target(1).Height)
With krtn
Application.EnableEvents = False
Target(1).Value = .Name
Target(1).Font.ColorIndex = 2
Application.EnableEvents = True
.Placement = xlMove
.ControlFormat.PrintObject = True
.LockAspectRatio = msoTrue
End With
Set krtn = Nothing
End Sub
Sub ПримерВставкиИзображенийНаЛист()
Dim Полотно As Range, Список As Range, Пиксел As Range
Set Полотно = Range("D2:O17")
Set Список = Range("T4:U7")
For i = 1 To Список.Rows.Count
ПутьКФайлуСКартинками = Список.Cells(i, 2).Value ' полный путь к файлу изображения
For Each Пиксел In Полотно
If Пиксел.Value = Список.Cells(i, 1).Value Then
' вставка картинки в диапазон a2:e3 (картинка вписывается в диапазон)
ВставитьКартинку Пиксел, ПутьКФайлуСКартинками, True, True, True
End If
Next
Next i
End Sub
Sub ВставитьКартинку(ByRef PicRange As Range, ByVal PicPath As String, _
Optional ByVal AdjustWidth As Boolean, _
Optional ByVal AdjustHeight As Boolean, _
Optional ByVal AdjustPicture As Boolean = False)
' ========== функция получает в качестве параметров: ====================
' PicRange - прямоугольный диапазон ячеек, поверх которого будет расположено изображение
' PicPath - полный путь к файлу картинки (файл в формате JPG, BMP, PNG, и т.д.)
' AdjustWidth - если TRUE, то включен режим подбора ширины (подгонка по высоте)
' AdjustHeight - если TRUE, то включен режим подбора высоты (подгонка по ширине)
' AdjustPicture - если TRUE, то подгоняются размеры картинки под ячейку,
' если FALSE (по умолчанию), то изменяются размеры ячейки
On Error Resume Next: Application.ScreenUpdating = False
' вставка изображения на лист
Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(PicPath)
' совмещаем левый верхний угол ячейки и картинки
ph.Top = PicRange.Top: ph.Left = PicRange.Left
K_picture = ph.Width / ph.Height ' вычисляем соотношение размеров сторон картинки
K_PicRange = PicRange.Width / PicRange.Height ' вычисляем соотношение размеров сторон диапазона ячеек
If AdjustPicture Then ' ПОДГОНЯЕМ РАЗМЕРЫ ИЗОБРАЖЕНИЯ под ячейку (оптимальный вариант)
' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
If AdjustWidth Then ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
If AdjustHeight Then ph.Height = PicRange.Height: ph.Width = ph.Height * K_picture
' AdjustWidth=TRUE и AdjustHeight=TRUE: вписываем картинку в ячейку (без соблюдения пропорций)
If AdjustWidth And AdjustHeight Then ph.ShapeRange.LockAspectRatio = msoFalse: ph.Width = PicRange.Width: ph.Height = PicRange.Height
Else ' ИЗМЕНЯЕМ РАЗМЕРЫ ЯЧЕЙКИ под размеры изображения (нежелательно при вставке НЕСКОЛЬКИХ картинок...)
If AdjustWidth Then ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth * ph.Width / PicRange.Cells(1).Width
While Abs(PicRange.Cells(1).Width - ph.Width) > 0.1 ' точный подбор ширины ячейки
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth - 0.2 * (PicRange.Cells(1).Width - ph.Width)
Wend
End If
If AdjustHeight Then ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight * ph.Height / PicRange.Cells(1).Height
While Abs(PicRange.Cells(1).Height - ph.Height) > 0.1 ' точный подбор высоты ячейки
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight - 0.2 * (PicRange.Cells(1).Height - ph.Height)
Wend
End If
End If
End Sub
Функция вставки картинок взята и чуть подправлена.
