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

Вход

Регистрация

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

 

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

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Ускорить простановку гиперссылок
ovechkin1973 Дата: Суббота, 19.01.2019, 17:57 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 429
Репутация: 1 ±
Замечаний: 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
Группа: Друзья
Ранг: Старожил
Сообщений: 2347
Репутация: 997 ±
Замечаний: 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
Группа: Проверенные
Ранг: Обитатель
Сообщений: 429
Репутация: 1 ±
Замечаний: 0% ±

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

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


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

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

Автор - ovechkin1973
Дата добавления - 19.01.2019 в 22:02
RAN Дата: Воскресенье, 20.01.2019, 03:25 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 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
Группа: Проверенные
Ранг: Обитатель
Сообщений: 429
Репутация: 1 ±
Замечаний: 0% ±

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

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


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

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

Автор - ovechkin1973
Дата добавления - 21.01.2019 в 19:13
  • Страница 1 из 1
  • 1
Поиск:

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