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

Вход

Регистрация

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

 

= Мир MS Excel/Ускорить простановку гиперссылок - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорить простановку гиперссылок (Макросы/Sub)
Ускорить простановку гиперссылок
ovechkin1973 Дата: Суббота, 19.01.2019, 17:57 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 338
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Все привет! С Крещением ВСЕХ! Есть желание ускорить код по простановке гиперссылок. Код не мой, с миру по нитке (что то с форума, а что то товарищ написал). Но если в файле с 10000-ю строками и в двух столбцах есть названия файлов, по которым в корневой папке, где сохранен сам файл нужно найти файл и проставить гиперссылки - работа Эксель зависает часов на 7.
В этой теме уважаемый RAN написал, что есть решение, которое работает на порядки быстрее. Показывал эту информацию своему товарищу - он к сожалению решить проблему по ускорению работы кода не смог.
Надежда у меня только на помощь этого форума. Файл прикладываю, единственно пришлось удалить строки в нем до приемлемого размера файла. Хотя думаю в этом случаю файл нужен только для просмотра кода. Все равно папок с файлами нет. Может это нужная инфомация - в корневом каталоге, где сохранен этот файл пока полтора десятка папок разной "глубины". Т.е. в каждой папке есть другие папки, а в них еще и так далее. Но "глубже" 5-ти папок нет (не знаю, как грамотно написать про это). Может это является причиной долгой работы кода.
К сообщению приложен файл: __c__20190118_1.xlsm(91.3 Kb)


Плохо когда не знаешь, да еще забудешь.
 
Ответить
СообщениеВсе привет! С Крещением ВСЕХ! Есть желание ускорить код по простановке гиперссылок. Код не мой, с миру по нитке (что то с форума, а что то товарищ написал). Но если в файле с 10000-ю строками и в двух столбцах есть названия файлов, по которым в корневой папке, где сохранен сам файл нужно найти файл и проставить гиперссылки - работа Эксель зависает часов на 7.
В этой теме уважаемый RAN написал, что есть решение, которое работает на порядки быстрее. Показывал эту информацию своему товарищу - он к сожалению решить проблему по ускорению работы кода не смог.
Надежда у меня только на помощь этого форума. Файл прикладываю, единственно пришлось удалить строки в нем до приемлемого размера файла. Хотя думаю в этом случаю файл нужен только для просмотра кода. Все равно папок с файлами нет. Может это нужная инфомация - в корневом каталоге, где сохранен этот файл пока полтора десятка папок разной "глубины". Т.е. в каждой папке есть другие папки, а в них еще и так далее. Но "глубже" 5-ти папок нет (не знаю, как грамотно написать про это). Может это является причиной долгой работы кода.

Автор - ovechkin1973
Дата добавления - 19.01.2019 в 17:57
krosav4ig Дата: Суббота, 19.01.2019, 19:02 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2052
Репутация: 853 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте. И вас с праздником!
пробуйте так [vba]
Код
Public Sub creategyperlinks(ByVal sheetname As String, ByVal colname2 As String, ByVal colname As String, ByVal startrow As Integer, ByVal path As String)
    Dim sMask As Variant, sFile As Variant, c As Range, Addr$      'объявление переменных
    Dim iMaxRowCount1 As Integer
    
    iMaxRowCount1 = getrowCounts(colname2, startrow)
    
     For Each sMask In Array("*.pdf", "*.7z")
        For Each sFile In FilenamesCollection(path, sMask, 5)
            With Sheets(sheetname).Range(colname & startrow & ":" & colname & iMaxRowCount1)
                sName = Mid(sFile, InStrRev(sFile, "\") + 1, Len(sFile))
                Set c = Range.Find(Mid(sName, 1, InStrRev(sName, ".") - 1), , xlValues, xlWhole, , , False, , False)
                If Not c Is Nothing Then
                    Addr = c.Address
                    Do
                        If c.Hyperlinks.Count = 0 Then
                            c.Hyperlinks.Add c, sFile, , , c.Text
                        End If
                        Set r = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Addr
                End If
            End With
        Next sFile
    Next sMask
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеЗдравствуйте. И вас с праздником!
пробуйте так [vba]
Код
Public Sub creategyperlinks(ByVal sheetname As String, ByVal colname2 As String, ByVal colname As String, ByVal startrow As Integer, ByVal path As String)
    Dim sMask As Variant, sFile As Variant, c As Range, Addr$      'объявление переменных
    Dim iMaxRowCount1 As Integer
    
    iMaxRowCount1 = getrowCounts(colname2, startrow)
    
     For Each sMask In Array("*.pdf", "*.7z")
        For Each sFile In FilenamesCollection(path, sMask, 5)
            With Sheets(sheetname).Range(colname & startrow & ":" & colname & iMaxRowCount1)
                sName = Mid(sFile, InStrRev(sFile, "\") + 1, Len(sFile))
                Set c = Range.Find(Mid(sName, 1, InStrRev(sName, ".") - 1), , xlValues, xlWhole, , , False, , False)
                If Not c Is Nothing Then
                    Addr = c.Address
                    Do
                        If c.Hyperlinks.Count = 0 Then
                            c.Hyperlinks.Add c, sFile, , , c.Text
                        End If
                        Set r = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Addr
                End If
            End With
        Next sFile
    Next sMask
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 19.01.2019 в 19:02
ovechkin1973 Дата: Суббота, 19.01.2019, 22:02 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 338
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте. И вас с праздником!
пробуйте так

Попробую. После отпишусь обязательно!


Плохо когда не знаешь, да еще забудешь.
 
Ответить
Сообщение
Здравствуйте. И вас с праздником!
пробуйте так

Попробую. После отпишусь обязательно!

Автор - ovechkin1973
Дата добавления - 19.01.2019 в 22:02
RAN Дата: Воскресенье, 20.01.2019, 03:25 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 5049
Репутация: 1004 ±
Замечаний: 0% ±

2010
[vba]
Код
Option Explicit

Sub МЯУ()
    Dim FSO As Object
    Dim FolderNamesCollection As New Collection     ' создаём пустую коллекцию
    Dim FolderPath$
    Dim FileTypes(), x
    Dim n$, s$
    Dim i&, j&, lr&
    Dim t!: t = Timer
    Const SearchDeep& = 5
    FileTypes = Array(".txt", ".rar")
    FolderPath = "D:\!XXXX"

    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFolderNamesUsingFSO FolderPath, FSO, FolderNamesCollection, SearchDeep  ' поиск
    With Sheets("хранение")
        Application.ScreenUpdating = False
        n = "K": GoSub HYPER
        n = "I": GoSub HYPER
        Debug.Print Format(Timer - t, "0.0000")
        Application.ScreenUpdating = True
        Exit Sub
HYPER:
        lr = .Cells(.Rows.Count, n).End(xlUp).Row
        For j = 1 To lr
            For i = 0 To UBound(FileTypes)
                For Each x In FolderNamesCollection
                    s = Dir(x & "\" & CStr(.Cells(j, n).Value) & FileTypes(i))
                    If s <> "" Then
                        If .Cells(j, n).Hyperlinks.Count = 0 Then
                            .Hyperlinks.Add .Cells(j, n), x & "\" & s
                            GoTo NextCell
                        End If
                    End If
                Next
            Next
NextCell:
        Next
        Return
    End With
End Sub

Function GetAllFolderNamesUsingFSO(ByVal FolderPath As String, ByRef FSO, _
                    ByRef FolderNamesCollection As Collection, ByVal SearchDeep As Long)
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
' перебор папок осуществляется в том случае, если SearchDeep > 1
' добавляет пути найденных файлов в коллекцию FileNamesColl
    Dim curfold As Object, sfol As Object
    
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                FolderNamesCollection.Add sfol.path
                GetAllFolderNamesUsingFSO sfol.path, FSO, FolderNamesCollection, SearchDeep
            Next
        End If
        Set curfold = Nothing    ' очищаем переменные
    End If
End Function
[/vba]


Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Воскресенье, 20.01.2019, 11:28
 
Ответить
Сообщение[vba]
Код
Option Explicit

Sub МЯУ()
    Dim FSO As Object
    Dim FolderNamesCollection As New Collection     ' создаём пустую коллекцию
    Dim FolderPath$
    Dim FileTypes(), x
    Dim n$, s$
    Dim i&, j&, lr&
    Dim t!: t = Timer
    Const SearchDeep& = 5
    FileTypes = Array(".txt", ".rar")
    FolderPath = "D:\!XXXX"

    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFolderNamesUsingFSO FolderPath, FSO, FolderNamesCollection, SearchDeep  ' поиск
    With Sheets("хранение")
        Application.ScreenUpdating = False
        n = "K": GoSub HYPER
        n = "I": GoSub HYPER
        Debug.Print Format(Timer - t, "0.0000")
        Application.ScreenUpdating = True
        Exit Sub
HYPER:
        lr = .Cells(.Rows.Count, n).End(xlUp).Row
        For j = 1 To lr
            For i = 0 To UBound(FileTypes)
                For Each x In FolderNamesCollection
                    s = Dir(x & "\" & CStr(.Cells(j, n).Value) & FileTypes(i))
                    If s <> "" Then
                        If .Cells(j, n).Hyperlinks.Count = 0 Then
                            .Hyperlinks.Add .Cells(j, n), x & "\" & s
                            GoTo NextCell
                        End If
                    End If
                Next
            Next
NextCell:
        Next
        Return
    End With
End Sub

Function GetAllFolderNamesUsingFSO(ByVal FolderPath As String, ByRef FSO, _
                    ByRef FolderNamesCollection As Collection, ByVal SearchDeep As Long)
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
' перебор папок осуществляется в том случае, если SearchDeep > 1
' добавляет пути найденных файлов в коллекцию FileNamesColl
    Dim curfold As Object, sfol As Object
    
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                FolderNamesCollection.Add sfol.path
                GetAllFolderNamesUsingFSO sfol.path, FSO, FolderNamesCollection, SearchDeep
            Next
        End If
        Set curfold = Nothing    ' очищаем переменные
    End If
End Function
[/vba]

Автор - RAN
Дата добавления - 20.01.2019 в 03:25
ovechkin1973 Дата: Понедельник, 21.01.2019, 19:13 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 338
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Уважаемый krosav4ig, ваш код мне товарищ приспособил к моему файлу. Сейчас гиперссылки проставляются от 5 до 15 минут (не 7 часов, как ранее). 5 минут дома, 15 минут на работе, когда файлы в сети хранятся.

Файл уважаемого RAN, мне пообещали в ближайшее время протестировать на этом же файле для сравнения производительности.


Плохо когда не знаешь, да еще забудешь.
 
Ответить
СообщениеУважаемый krosav4ig, ваш код мне товарищ приспособил к моему файлу. Сейчас гиперссылки проставляются от 5 до 15 минут (не 7 часов, как ранее). 5 минут дома, 15 минут на работе, когда файлы в сети хранятся.

Файл уважаемого RAN, мне пообещали в ближайшее время протестировать на этом же файле для сравнения производительности.

Автор - ovechkin1973
Дата добавления - 21.01.2019 в 19:13
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорить простановку гиперссылок (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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