Страницы: 1 2 След.
RSS
Использование макросом словаря в виде столбца адресов файлов.
 
Здравствуйте, друзья.

Помогите поправить макрос.
Макрос сейчас расстанавливает иконки по листу, но мне кажется, что делает он это медленно.

Как заставить макрос использовать "словарь" в виде столбца адресов файлов ?
(Чтобы он не просматривал все названия файлов при каждом нажатии на кнопку, а смотрел уже в готовые адреса, выписанные в желтый столбец).
Мне кажется, что так он быстрее будет расставлять иконки.
 
visors16, приветствую.

Не хотите вместо Copy/Paste попробовать Duplicate?
Код
...
              End With

'              ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Copy
            Do
                If m_rnFind.Address <> m_stAddress Then
'                    ActiveSheet.Paste
                    myPic.Duplicate
                    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
...
 
Цитата
visors16 написал:
Мне кажется, что так он быстрее будет расставлять иконки.
А вы сделайте замер, при количестве файлов равном вашей таблице, и убедитесь верно ли ваше предположение или нет. Наперед скажу, время затрачиваемое на поиск и перебор много меньше чем на саму вставку и последующее копирование. Конечно если файлов не миллионы а вставить надо единицы из них. Видимо в прошлой теме вы проигнорировали мои примечания.
По вопросам из тем форума, личку не читаю.
 
andypetr, понятно.
Как макрос будет выглядеть с вашим кодом ?
 
БМВ, Ясно.
Я провел замер. Вижу, что немного этот макрос подтормаживает.
Вот ищу способы со словарем в желтом столбце - как-то его сделать. Может побыстрее будет работать.
 
Цитата
visors16 написал:
Вижу, что немного этот макрос подтормаживает.
Как же трудно . нужно не на общее время смотреть а на то , какая часть занимает какое время. И основное, так как исходный код соджержал сравнение частичного вхождения, то и я делал по аналогии, то есть искал все варианты из словаря. Если в таблице  наименования один в один с картинкой,то совершенно иной алгоритм можно использовать, а именно брать ячейку со значением, вставлять картинку с помошью подготовленного словаря и искать аналоги в диапазоне расставляя дубли картинок. По окончанию заносить в другой словать обработанное значение, и переходить к следующей ячейке, если значение есть во втором словаре, то с этим значением ничего делать не нужно. Идем дальше и так до конца диапазона.

Дерзайте
По вопросам из тем форума, личку не читаю.
 
БМВ, понятно. Спасибо за ответ.

Помогите изменить макрос - как вы описали.
 
Цитата
написал:
Как макрос будет выглядеть с вашим кодом ?

Так же и будет выглядеть, как я написал: закомментированные строки с Copy и Paste, вставленная строка с Duplicate.
Скорость сразу стала нормальной, без всяких желтых столбцов (но, конечно, проверить нужно корректность расстановки иконок).
Copy/Paste в Excel-VBA крайне нежелательно применять.
 
Цитата
andypetr написал:
Скорость сразу стала нормальной
ну прям чтоб в разы стало быстрее конесно нет, но согласен, метод duplicate более быстрый. Остальное зависит от органтзации и структуры данных, колличества повторов  в таблице, а основное время будет тратится на вставку из файла.
По вопросам из тем форума, личку не читаю.
 
Цитата
написал:
ну прям чтоб в разы стало быстрее конесно нет,
Я, прежде чем написать, проверял на приложенном файле.
Вариант с Copy/Paste отрабатывал за 5-10 минут (лень запускать ещё раз).
Вариант с Duplicate - менее 1 секунды (другое дело, что ещё нужно проверить корректность замены, но это уже дело ТС).
 
Цитата
andypetr написал:
5-10 минут
хм. У меня 0.9 сек и 0.6 по замерам таймера. Может от версии по зависит.
По вопросам из тем форума, личку не читаю.
 
У меня Excel 2016: 4 минуты <> 1 сек.

Я думаю, из-за разницы в 0,3 сек. visors16 не стал бы переживать... :)
 
andypetr,  это мой скрипт
2,5625 - 2013 на виртуалке.
0,9  ноутбук 10 летней давности (i5 но с SSD).
По вопросам из тем форума, личку не читаю.
 
andypetr, спасибо.
Теперь быстрее работать стал.

Только непонятно - как макросом заполнить желтый столбец ?
(это я имею ввиду кнопку "заполнение словаря")
 
Алгоритм немного изменил, но появилась иная проблема, а именно , чувствительность к регистру. Но в целом еще чуть быстрее.

Цитата
visors16 написал:
Только непонятно - как макросом заполнить желтый столбец ?
- а оно надо?
Изменено: БМВ - 07.02.2024 20:02:22
По вопросам из тем форума, личку не читаю.
 
БМВ, спасибо.
А как еще больше ускорить работу макроса ?

Неужели использование словаря не увеличит скорость работы ?
Ведь макрос не будет тратить время на поиск нужных картинок (особенно если их много), а мгновенно просмотрит столбец с адресами и разместит картинки в ячейках.
Изменено: visors16 - 08.02.2024 03:12:35
 
Цитата
visors16 написал:
А как еще больше ускорить работу макроса
Не получится, потому что (судя из моей проверки) ScrrenUpdating = False не работает на активном листе.
 
Цитата
visors16 написал:
А как еще больше ускорить работу макроса ?
Можно попробовать если у вас позднее связывание для словаря, то заменить на раннее. Этим вы перенесете часть затрат времени с ним связанную, с момента выполнения программы на момент компиляции.
Изменено: R091n - 08.02.2024 06:55:42
 
Цитата
visors16 написал:
Ведь макрос не будет тратить время на поиск нужных картинок (особенно если их много)
Уже в который раз повторяю: Единственный проход по каталогу с картинками и составление словаря занимает мгновение. Большую часть  времени тратится на вставку и мультиплицирование.

Не словарь, а таблица соответствий с миниатюрами в виде таблице на листе , которая постоянно находится на листе и картинки не требуют загрузки - это ускорит.

Цитата
testuser написал:
ScrrenUpdating = False не работает на активном листе
плохая проверка. Это не уровень листа или книги, другое дело что после того как включили, происходит обновление и это для картинок уже целый процесс.

Цитата
R091n написал:
то заменить на раннее.
что даст не существенную к остальному времени прибавку скорости, но может добавить проблем иного плана.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
плохая проверка.
запускаемых с кнопки - одно время, запускаемых из модуля - другое, в 5 р. быстрее.. видится таки, что хорошая... )
 
Цитата
testuser написал:
запускаемых с кнопки - одно время, запускаемых из модуля - другое, в 5 р. быстре
и так и так запускаю  - разницы нет. Опция может быть только в режиме пошагового исполнения влиять.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ: что даст не существенную к остальному времени прибавку скорости, но может добавить проблем иного плана.
сокращение времени на больших объёмах будет заметно, а проблемы "иного плана" отсутствуют.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
окращение времени на больших объёмах будет заметно,
Алексей, ну если биться за наносекунды, то да, но если 99,9 процентов времени занимает операция не связанная с этим, то стоит ли копья ломать. А про переполнение стека забывать не стоит. Вроде и Владимир и Дмитрий об этом писали.
По вопросам из тем форума, личку не читаю.
 
БМВ, не вижу смысла объяснять тебе уже в который раз одно и то же. Писал для остальных.
Переполнение стека не зависит от связывания. Тесты я делал в темах.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
БМВ написал:
и так и так запускаю  - разницы нет
такой глюк заметил на 19 офисе, на 21 его нет.
 
Цитата
Jack Famous написал:
не вижу смысла объяснять тебе уже в который раз одно и то же.
и у кого двойные стандарты после этого ?   :D
По вопросам из тем форума, личку не читаю.
 
Цитата
написал:
запускаемых с кнопки - одно время, запускаемых из модуля - другое, в 5 р. быстрее
Вот мне - можно то, которое в 5 раз быстрее ?
 
Цитата
visors16 написал:
Вот мне - можно то, которое в 5 раз быстрее ?
Если офис 19 или старше (в 07 уже не работает, там всегда медленно) ставите оператор Stop в начале процедуры - должно работать
Код
Stop
t = Timer

Еще способ: сделать простую юзерформу. В начале и в конце процедуры прописать. В чем суть, когда окно таблицы не активно, работает быстрее (у меня так)
Код
UserForm1.Show 0
'***
UserForm1.Hide
Изменено: testuser - 09.02.2024 02:38:30
 
Цитата
написал:
ставите оператор Stop в начале процедуры - должно работать
Понятно.
Вы можете в имеющемся коде - поставить этот Stop ?

Я просто не знаю о какой процедуре идет речь.
Код
Dim sl



Sub Расстановка_иконок()
t = Timer
Application.ScreenUpdating = False
ОчисткаТаблицы

    Dim R, lr, k, pat, I, f
    Dim m() As Variant
   
    Dim myPic As Shape
    Dim FSO As Object
    'Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("Scripting.Dictionary")
    Set sl2 = CreateObject("Scripting.Dictionary")
    Search2 ActiveWorkbook.Path
    k = sl.keys
  
    Set D = ActiveSheet.Range("H:H,L:L,P:P,T:T,X:X,AB:AB,AF:AF,AJ:AJ,AN:AN,AQ:AQ,AT:AT,AW:AW,AZ:AZ,BD:BD,BH:BH")
    Set D = Intersect(D, Range("13:54")).SpecialCells(xlCellTypeConstants)
    For Each cell In D
    If cell <> "" Then
    Lcell = LCase(cell)
    If sl2.Exists(Lcell) Then
        If sl2(Lcell) > 0 Then
            ActiveSheet.Shapes(sl2(Lcell)).Duplicate
            With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                .Top = cell.Offset(0, -1).Top + 1
                .Left = cell.Offset(0, -1).Left + 1
                .Width = cell.Offset(0, -1).Width - 2
                .Height = cell.Offset(0, -1).Height * 3 - 2
            End With
        End If
        Else
            If sl.Exists(Lcell) Then
                Set myPic = ActiveSheet.Shapes.AddPicture( _
                    Filename:=sl(Lcell), _
                    linktofile:=msoFalse, _
                    savewithdocument:=msoCTrue, _
                    Left:=cell.Offset(0, -1).Left + 1, _
                    Top:=cell.Offset(0, -1).Top + 1, _
                    Width:=cell.Offset(0, -1).Width - 2, _
                    Height:=cell.Offset(0, -1).Height * 3 - 2)
                myPic.LockAspectRatio = msoFalse
            sl2(Lcell) = ActiveSheet.Shapes.Count
            End If
        End If
        End If
    Next
'    For Each PicName In k
'        'With d
'        Set m_rnFind = D.Find(What:=PicName, LookAt:=xlWhole, MatchCase:=False)
'        If Not m_rnFind Is Nothing Then
'            m_stAddress = m_rnFind.Address
'            'Hide the column, and then find the next X.
'             With m_rnFind
'                Set myPic = ActiveSheet.Shapes.AddPicture( _
'                                Filename:=sl(PicName), _
'                                linktofile:=msoFalse, _
'                                savewithdocument:=msoCTrue, _
'                                Left:=.Offset(0, -1).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
'
'              ' [-]
'              ' ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Copy
'              '
'            Do
'                If m_rnFind.Address <> m_stAddress Then
'
'                    ' [-]
'                    'ActiveSheet.Paste
'                    '
'                    ' [+]
'                    myPic.Duplicate
'                    '
'
'                    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
'                        .Top = m_rnFind.Offset(0, -1).Top + 1
'                        .Left = m_rnFind.Offset(0, -1).Left + 1
'                        .Width = m_rnFind.Offset(0, -1).Width - 2
'                        .Height = m_rnFind.Offset(0, -1).Height * 3 - 2
'                    End With
'                End If
'                Set m_rnFind = D.FindNext(m_rnFind)
'                On Error Resume Next
'            Loop While Not m_rnFind Is Nothing And m_rnFind.Address <> m_stAddress
'        End If
'        Next
    
Range("A1").Select
Application.ScreenUpdating = True
Debug.Print Timer - t
End Sub


 Function Search2(Fold As String)  
 Dim SubFold As Object, Fil As Object, FSO As Object
    Set objShellApp = CreateObject("Shell.Application")
    Set FSO = CreateObject("Scripting.FileSystemObject")

   Set objFolder = objShellApp.Namespace(Fold & "\")
   Set objFolderItems = objFolder.Items()
   objFolderItems.Filter 64, "*.png;*.jpg"
   For Each Fil In objFolderItems
     sl(LCase(FSO.Getbasename(Fil.Path))) = Fil.Path
   Next
   objFolderItems.Filter 32, "*"
   For Each SubFold In objFolderItems
     Search2 SubFold.Path
   Next SubFold
End Function


Sub ОчисткаТаблицы()  
    Dim pic As Shape
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            If Not Application.Intersect(pic.TopLeftCell, Range("G13:BI54")) Is Nothing Then
                pic.Delete
            End If
        End If
    Next pic
    Application.ScreenUpdating = True
End Sub
 
Цитата
visors16 написал:
Я просто не знаю о какой процедуре идет речь
В этой. С телефона пишу сейчас. Вариант с формой получше чуток..
Страницы: 1 2 След.
Наверх