Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Неправильное размещение иконок на листе - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Неправильное размещение иконок на листе (Макросы/Sub)
Неправильное размещение иконок на листе
SkyGreen Дата: Вторник, 28.11.2023, 13:06 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Добрый день.
Помогите поправить макрос.

Макрос сейчас расставляет иконки по таблице 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]
К сообщению приложен файл: fajly_1.rar (23.7 Kb)
 
Ответить
СообщениеДобрый день.
Помогите поправить макрос.

Макрос сейчас расставляет иконки по таблице 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]

Автор - SkyGreen
Дата добавления - 28.11.2023 в 13:06
Pelena Дата: Вторник, 28.11.2023, 14:39 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19137
Репутация: 4409 ±
Замечаний: ±

Excel 365 & Mac Excel
Здравствуйте.
Попробуйте вместо строки
[vba]
Код
If InStr(Cells(rw, co), m(r, 1)) > 0 Then
[/vba]
написать
[vba]
Код
If Cells(rw, co) = m(r, 1) Then
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Попробуйте вместо строки
[vba]
Код
If InStr(Cells(rw, co), m(r, 1)) > 0 Then
[/vba]
написать
[vba]
Код
If Cells(rw, co) = m(r, 1) Then
[/vba]

Автор - Pelena
Дата добавления - 28.11.2023 в 14:39
SkyGreen Дата: Вторник, 28.11.2023, 15:01 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Pelena, спасибо за ответ, но все равно на некоторые ячейки - идет опять нагромождение иконок.

(можно видеть, что в ячейке J45 - размещается 3 иконки)
 
Ответить
СообщениеPelena, спасибо за ответ, но все равно на некоторые ячейки - идет опять нагромождение иконок.

(можно видеть, что в ячейке J45 - размещается 3 иконки)

Автор - SkyGreen
Дата добавления - 28.11.2023 в 15:01
Pelena Дата: Вторник, 28.11.2023, 15:34 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19137
Репутация: 4409 ±
Замечаний: ±

Excel 365 & Mac Excel
эту строку
[vba]
Код
If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
[/vba]
поменяйте на
[vba]
Код
If InStr(1, k(i), m(r, 2) & ".", vbTextCompare) > 0 Then
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеэту строку
[vba]
Код
If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
[/vba]
поменяйте на
[vba]
Код
If InStr(1, k(i), m(r, 2) & ".", vbTextCompare) > 0 Then
[/vba]

Автор - Pelena
Дата добавления - 28.11.2023 в 15:34
SkyGreen Дата: Вторник, 28.11.2023, 15:43 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Pelena, спасибо.
Теперь разместил иконки правильно.
 
Ответить
СообщениеPelena, спасибо.
Теперь разместил иконки правильно.

Автор - SkyGreen
Дата добавления - 28.11.2023 в 15:43
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Неправильное размещение иконок на листе (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!