Макрос сейчас расставляет иконки по таблице F42:J50, ориентируясь на то значение которое вписано в каждую конкретную ячейку этой таблицы. Вместо того, чтобы расставить одну иконку в одну ячейку по точному совпадению (со словами прописанными в столбце X4:X), макрос расставляет по куче иконок в каждой ячейке таблицы F42:J50, где есть хотя бы одно совпадение с ключевыми словами из X4:X , нагромождая иконки друг на друга. Это касается только тех ячеек, где стоят числовые значения.
Как поправить макрос, чтобы исчезло это нагромождение - и расставлялась бы одна иконка на одну ячейку - по точному совпадению ?
Вот сам код имеющегося макроса и файл-пример: [vba]
Код
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
[/vba]
Добрый день. Помогите поправить макрос.
Макрос сейчас расставляет иконки по таблице F42:J50, ориентируясь на то значение которое вписано в каждую конкретную ячейку этой таблицы. Вместо того, чтобы расставить одну иконку в одну ячейку по точному совпадению (со словами прописанными в столбце X4:X), макрос расставляет по куче иконок в каждой ячейке таблицы F42:J50, где есть хотя бы одно совпадение с ключевыми словами из X4:X , нагромождая иконки друг на друга. Это касается только тех ячеек, где стоят числовые значения.
Как поправить макрос, чтобы исчезло это нагромождение - и расставлялась бы одна иконка на одну ячейку - по точному совпадению ?
Вот сам код имеющегося макроса и файл-пример: [vba]
Код
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