Все привет! С Крещением ВСЕХ! Есть желание ускорить код по простановке гиперссылок. Код не мой, с миру по нитке (что то с форума, а что то товарищ написал). Но если в файле с 10000-ю строками и в двух столбцах есть названия файлов, по которым в корневой папке, где сохранен сам файл нужно найти файл и проставить гиперссылки - работа Эксель зависает часов на 7. В этой теме уважаемый RAN написал, что есть решение, которое работает на порядки быстрее. Показывал эту информацию своему товарищу - он к сожалению решить проблему по ускорению работы кода не смог. Надежда у меня только на помощь этого форума. Файл прикладываю, единственно пришлось удалить строки в нем до приемлемого размера файла. Хотя думаю в этом случаю файл нужен только для просмотра кода. Все равно папок с файлами нет. Может это нужная инфомация - в корневом каталоге, где сохранен этот файл пока полтора десятка папок разной "глубины". Т.е. в каждой папке есть другие папки, а в них еще и так далее. Но "глубже" 5-ти папок нет (не знаю, как грамотно написать про это). Может это является причиной долгой работы кода.
Все привет! С Крещением ВСЕХ! Есть желание ускорить код по простановке гиперссылок. Код не мой, с миру по нитке (что то с форума, а что то товарищ написал). Но если в файле с 10000-ю строками и в двух столбцах есть названия файлов, по которым в корневой папке, где сохранен сам файл нужно найти файл и проставить гиперссылки - работа Эксель зависает часов на 7. В этой теме уважаемый RAN написал, что есть решение, которое работает на порядки быстрее. Показывал эту информацию своему товарищу - он к сожалению решить проблему по ускорению работы кода не смог. Надежда у меня только на помощь этого форума. Файл прикладываю, единственно пришлось удалить строки в нем до приемлемого размера файла. Хотя думаю в этом случаю файл нужен только для просмотра кода. Все равно папок с файлами нет. Может это нужная инфомация - в корневом каталоге, где сохранен этот файл пока полтора десятка папок разной "глубины". Т.е. в каждой папке есть другие папки, а в них еще и так далее. Но "глубже" 5-ти папок нет (не знаю, как грамотно написать про это). Может это является причиной долгой работы кода.ovechkin1973
Здравствуйте. И вас с праздником! пробуйте так [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]
Здравствуйте. И вас с праздником! пробуйте так [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
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]
[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
Уважаемый krosav4ig, ваш код мне товарищ приспособил к моему файлу. Сейчас гиперссылки проставляются от 5 до 15 минут (не 7 часов, как ранее). 5 минут дома, 15 минут на работе, когда файлы в сети хранятся.
Файл уважаемого RAN, мне пообещали в ближайшее время протестировать на этом же файле для сравнения производительности.
Уважаемый krosav4ig, ваш код мне товарищ приспособил к моему файлу. Сейчас гиперссылки проставляются от 5 до 15 минут (не 7 часов, как ранее). 5 минут дома, 15 минут на работе, когда файлы в сети хранятся.
Файл уважаемого RAN, мне пообещали в ближайшее время протестировать на этом же файле для сравнения производительности.ovechkin1973
Плохо когда не знаешь, да еще забудешь. Правильно сформулированный вопрос содержит половину ответа.