Добрый день.
Помогите поправить макрос.
Макрос расставляет иконки по таблице F42:J50, ориентируясь на то значение которое вписано в каждую конкретную ячейку этой таблицы.
Вместо того, чтобы расставить одну иконку в одну ячейку по точному совпадению (со словами прописанными в столбце X4:X), макрос расставляет по куче иконок в каждой ячейке таблицы F42:J50, где есть хотя бы одно совпадение с ключевыми словами из X4:X , нагромождая иконки друг на друга.
Это касается только тех ячеек, где стоят числовые значения.
Как поправить макрос, чтобы исчезло это нагромождение - и расставлялась бы одна иконка на одну ячейку - по точному совпадению ?
Вот сам код и файл-пример:
| Код |
|---|
Option Explicit
Dim sl
Sub Макрос1()
Dim r, lr, m, k, pat, i, f
Dim myPic As Shape
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set sl = CreateObject("Scripting.Dictionary")
pat = ActiveWorkbook.Path
Search fso.GetFolder(pat)
k = sl.keys
With ActiveSheet
lr = Cells(Rows.Count, 25).End(xlUp).Row
m = .Cells(4, 24).Resize(lr - 3, 2).Value
Dim rw&, co&
For rw = 42 To 51 Step 3
For co = 6 To 10 Step 1
For r = 1 To UBound(m)
If InStr(Cells(rw, co), m(r, 1)) > 0 Then
For i = 0 To UBound(k)
If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
pat = sl(k(i))
With .Cells(rw, co)
Set myPic = ActiveSheet.Shapes.AddPicture( _
Filename:=pat, _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=.Offset(0, 0).Left + 1, _
Top:=.Offset(0, -1).Top + 1, _
Width:=.Offset(0, -1).Width - 2, _
Height:=.Offset(0, -1).Height * 3 - 2)
myPic.LockAspectRatio = msoFalse
End With
End If
Next i
End If
Next r
Next co
Next rw
End With
End Sub
Function Search(Fold As Object)
Dim SubFold As Object, Fil As Object
For Each SubFold In Fold.SubFolders
Search SubFold
Next SubFold
For Each Fil In Fold.Files
If InStr(1, Fil.Name, ".png", vbTextCompare) > 0 Then
sl(Fil.Name) = Fil.Path
End If
Next Fil
End Function
|
