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

Вход

Регистрация

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

 

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

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

Excel 2016
Здравствуйте. Помогите поправить макрос.

Макрос по таблице размещает иконки.
Но он их как-то так размещает, что в одну ячейку - вписывает почти все иконки, нагромождая их оду на другую.

По идее - на одну ячейку может быть размещена только одна иконка.
А если иконка среди картинок не найдена, то ее просто не надо отображать. А если макрос находит несколько подходящих под условия картинок - то нужно просто выбрать первую попавшуюся.
Мне кажется что тут происходит какой-то сбой из-за того, что макрос если не находит нужную картинку - начинает неправильно работать.

Подскажите - как поправить макрос, чтобы он отображал не более одной иконки на одну ячейку ?

[vba]
Код
Option Explicit
Dim sl

Sub Иконки()

    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
    Search2 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 = 11 To 37 Step 3
        For co = 11 To 21 Step 1
        For r = 1 To UBound(m)
            If Cells(rw, co) = m(r, 1) 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 Search2(Fold As Object)
Dim SubFold As Object, Fil As Object

   For Each SubFold In Fold.SubFolders
     Search2 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]
К сообщению приложен файл: 174359.rar (31.7 Kb)
 
Ответить
СообщениеЗдравствуйте. Помогите поправить макрос.

Макрос по таблице размещает иконки.
Но он их как-то так размещает, что в одну ячейку - вписывает почти все иконки, нагромождая их оду на другую.

По идее - на одну ячейку может быть размещена только одна иконка.
А если иконка среди картинок не найдена, то ее просто не надо отображать. А если макрос находит несколько подходящих под условия картинок - то нужно просто выбрать первую попавшуюся.
Мне кажется что тут происходит какой-то сбой из-за того, что макрос если не находит нужную картинку - начинает неправильно работать.

Подскажите - как поправить макрос, чтобы он отображал не более одной иконки на одну ячейку ?

[vba]
Код
Option Explicit
Dim sl

Sub Иконки()

    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
    Search2 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 = 11 To 37 Step 3
        For co = 11 To 21 Step 1
        For r = 1 To UBound(m)
            If Cells(rw, co) = m(r, 1) 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 Search2(Fold As Object)
Dim SubFold As Object, Fil As Object

   For Each SubFold In Fold.SubFolders
     Search2 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
Дата добавления - 08.12.2023 в 08:22
NikitaDvorets Дата: Пятница, 08.12.2023, 13:11 | Сообщение № 2
Группа: Авторы
Ранг: Ветеран
Сообщений: 526
Репутация: 115 ±
Замечаний: 0% ±

Excel 2019
SkyGreen, добрый день.
Цитата
как поправить макрос, чтобы он отображал не более одной иконки на одну ячейку ?

По-видимому, выходить из цикла, когда картинка уже нарисована.
Правки прилагаются.
К сообщению приложен файл: test_345_nekorrektnoe_razmeshh.rar (40.7 Kb)
 
Ответить
СообщениеSkyGreen, добрый день.
Цитата
как поправить макрос, чтобы он отображал не более одной иконки на одну ячейку ?

По-видимому, выходить из цикла, когда картинка уже нарисована.
Правки прилагаются.

Автор - NikitaDvorets
Дата добавления - 08.12.2023 в 13:11
SkyGreen Дата: Пятница, 08.12.2023, 17:34 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
NikitaDvorets, спасибо за ответ.

Но не работает.
Расстановка картинок идет не по таблице X7:Y.
Я поставил в таблице - несуществующие названия, но макрос стал самостоятельно, без моего участия определять - куда какую иконку поставить:
Хотя в случае новых адресов - он ничего расставить не должен был.
К сообщению приложен файл: rasstanovka_ikonok_08_12_2023_.xlsm (27.4 Kb)
 
Ответить
СообщениеNikitaDvorets, спасибо за ответ.

Но не работает.
Расстановка картинок идет не по таблице X7:Y.
Я поставил в таблице - несуществующие названия, но макрос стал самостоятельно, без моего участия определять - куда какую иконку поставить:
Хотя в случае новых адресов - он ничего расставить не должен был.

Автор - SkyGreen
Дата добавления - 08.12.2023 в 17:34
NikitaDvorets Дата: Понедельник, 25.12.2023, 14:33 | Сообщение № 4
Группа: Авторы
Ранг: Ветеран
Сообщений: 526
Репутация: 115 ±
Замечаний: 0% ±

Excel 2019
SkyGreen, попробуйте вариант с измененной логикой расстановки картинок.
К сообщению приложен файл: rasstanovka_ikonok_25_12_2023_.xlsm (34.2 Kb)


Сообщение отредактировал NikitaDvorets - Понедельник, 25.12.2023, 14:34
 
Ответить
СообщениеSkyGreen, попробуйте вариант с измененной логикой расстановки картинок.

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

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