1

Тема: VBA: Макрос на кнопку, проход по папкам, сравнение с наименованием, со

Добрый день. Возникла необходимость в написании макроса, сам к сожалению только начал изучать данный вопрос.

Есть лист excel (рис.1).  в нем указаны комплекты документов. В столбцах L-O сейчас руками созданы гиперссылки на необходимые папки.
Есть папка на диске с входящими и исходящими письмами (рис.2). Папок и входящих и исходящих писем очень много, и в ручную каждый раз добавлять гиперссылки очень трудозатратно.
Задача состоит в следующем, по нажатию кнопки делать проход по папкам и подпапкам, сравнивать наименование в столбце "B" листа excel и папках (рис3), и создавать столбцы с гиперссылками на папки.
рисунки и сам файл excel приложен.

Post's attachments

макрос.zip 599.14 kb, 3 downloads since 2023-04-17 

You don't have the permssions to download the attachments of this post.

2

Re: VBA: Макрос на кнопку, проход по папкам, сравнение с наименованием, со

Я в общем то в VBA не шарю. Но однажды сталкивался с необходимостью получить перечень содержимого папки (файлы, подпапки, файлы в подпапках, подподпапки в подпапках и т. д.). Имеется готовое решение на AutoHotkey. http://forum.script-coding.com/viewtopic.php?id=15032. Припоминаю, что я на основе выгрузки скрипта создавал HTML-файл, открывал его через браузер, щёлкал по интересующему меня файлу, в результате чего он открывался в соответствующей программе.  Таким образом избавился от необходимости вручную каждый раз добавлять гиперссылки. Но если нужно именно макрос для excel, то этот вариант Вам не подойдёт.

3 (изменено: VBAdevelope, 2023-04-18 11:59:35)

Re: VBA: Макрос на кнопку, проход по папкам, сравнение с наименованием, со

ivandor421
Подозреваю, что отвечал уже на другом форуме, поскольку вопрос такой же. Продублирую код:
Там 4 колонки с входящими\исходящими. Что куда вставлять?
Вот код, он смотрит в одну папку и перебирает в ней файлы, сравнивая с кодом (конец строки до тире) и подкаталоги рекрсивно

Sub GEGJ()
Dim oWB As Workbook
Dim rCell As Range, rSearchRange As Range
Dim sFolder$, sCode$, sFileName$
Dim oFso As Object
Dim oFolder As Object

Set oWB = ActiveWorkbook
sFolder = "D:\" 'я пишу Д, вы свою
'Я пишу лист1, вы своё название листа
Set rSearchRange = oWB.Sheets("Лист1").Range("B1:B" & Sheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row)

For Each rCell In rSearchRange
    If Not IsEmpty(rCell.Value) Then
        sCode = "-" & Right(rCell.Value, Len(rCell.Value) - InStrRev(rCell.Value, "-"))
        Set oFso = CreateObject("Scripting.FileSystemObject")
        Set oFolder = oFso.GetFolder(sFolder)
        Call RecursiveSubFolders(oFolder, sCode, oWB)
    Else
        Exit Sub
    End If
Next rCell
Set oFso = Nothing
End Sub
Sub RecursiveFiles(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook)
Dim oFile As Object
Dim sFilePath As String
    For Each oFile In oFolder.Files
        sFil = oFile.Name
        If InStr(oFile.Name, sCode) >= 1 Then
            sFilePath = oFile.Path
            oWB.Sheets("Лист1").Range("L" & rCell.Row) = "=HYPERLINK(" & sFilePath & ")"
        End If
    Next oFile
End Sub
Sub RecursiveSubFolders(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook)
Dim oSubFolder As Object
    If oFolder.Subfolders.Count >= 1 Then
        For Each oSubFolder In oFolder.Subfolders
            Call RecursiveFiles(oFolder, sCode, oWB)
            If oFolder.Subfolders.Count >= 1 Then
                Call RecursiveSubFolders(oSubFolder, sCode, oWB)
            End If
        Next oSubFolder
    Else
        Call RecursiveFiles(oFolder, sCode, oWB)
    End If
End Sub

Если надо в двух папках смотреть, то добавляете вокруг кода

For Цикл = 1 to 2
Select Case Цикл
'сюда пишем  для входящих
Case 1:
sFolder = "ваш путь"
'сюда пишем  для исходящих
Case 2:
sFolder = "ваш путь"
End Select
'А сюда код из основной процедуры
Next Цикл

И тогда ещё нужно передавать в подпроцедуры значение столбца, куда ставить.
По вашему ТЗ неясно, что должно происходить по нажатию кнопки, как выбирать столбцы для вставки ссылки, как вы собираете указывать папку поиска, заранее или каждый раз выбирать в файловой системе. А также критерии выбора участка текста ячейки, по которому будет вестись поиск в именах файлов. Если это всегда будет текст вида "-символы-символы" и ищем по символам без первого тире, то нужно это указатьо
На данный момент макрос перебирает значения столбца "B" и отбирает последние символы до тире и ищет во всех папках любого уровня вложенности на диске  "D:\" файлы с именем содержащим данные символы и копирует путь к файлу в столбец L.

Разработка VBA макросы Excel, Word на заказ.
Сказать спасибо на Юмани

4 (изменено: VBAdevelope, 2023-04-18 12:04:37)

Re: VBA: Макрос на кнопку, проход по папкам, сравнение с наименованием, со

Подправил код. Вот для двух каталогов (1 входящий - вставляется в L; 2 - исходящий, вставляется в K). Из ячейки берётся sCode - с правого края текст формата "-символы-символы" без первого тире.

Sub GetHyperlinksForFilesWithCodeNameFromB()
Dim oWB As Workbook
Dim rCell As Range, rSearchRange As Range
Dim sFolder$, sCode$, sFileName$, sSheetName$, sVal$
Dim oFso As Object
Dim oFolder As Object

Set oWB = ActiveWorkbook
sSheetName = "Лист1" 'Я пишу лист1, вы своё название листа
Set rSearchRange = oWB.Sheets(sSheetName).Range("B1:B" & Sheets(sSheetName).Cells(Rows.Count, 2).End(xlUp).Row)

For Each rCell In rSearchRange
    If Not IsEmpty(rCell.Value) Then
        sVal = rCell.Value
        sCode = Right(sVal, Len(sVal) - InStrRev(sVal, "-"))
        sVal = Left(sVal, Len(sVal) - Len(sCode) - 1)
        sCode = Right(sVal, Len(sVal) - InStrRev(sVal, "-")) & "-" & sCode
        For Цикл = 1 To 2
            Select Case Цикл
                'сюда пишем  для входящих
                Case 1:
                    sFolder = "D:\Входящие" 'Например "D:\Входящие\"
                    sCol = "L" 'Столбец, куда будем вставлять
                'сюда пишем  для исходящих
                Case 2:
                    sFolder = "D:\Исходящие" 'Например "D:\Исходящие\"
                    sCol = "K" 'Столбец, куда будем вставлять
            End Select
            'А сюда код из основной процедуры
            
            Set oFso = CreateObject("Scripting.FileSystemObject")
            Set oFolder = oFso.GetFolder(sFolder)
            Call RecursiveSubFolders(oFolder, sCode, oWB, sCol, sSheetName, rCell)
        Next Цикл
    Else
        Exit Sub
    End If
Next rCell
Set oFso = Nothing
End Sub

Sub RecursiveFiles(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook, _
                            ByVal sCol As String, ByVal sSheetName As String, ByRef rCell As Range)
Dim oFile As Object
Dim sFilePath As String
    For Each oFile In oFolder.Files
        sFil = oFile.Name
        If InStr(oFile.Name, sCode) >= 1 Then
            sFilePath = oFile.Path
            oWB.Sheets(sSheetName).Hyperlinks.Add Anchor:=oWB.Sheets(sSheetName).Range(sCol & rCell.Row), _
                                                    Address:=sFilePath, TextToDisplay:=Format(Date, "dd.mm.yyyy")
        End If
    Next oFile
End Sub

Sub RecursiveSubFolders(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook, _
                            ByVal sCol As String, ByVal sSheetName As String, ByRef rCell As Range)
Dim oSubFolder As Object
    If oFolder.Subfolders.Count >= 1 Then
        For Each oSubFolder In oFolder.Subfolders
            Call RecursiveFiles(oFolder, sCode, oWB, sCol, sSheetName, rCell)
            If oFolder.Subfolders.Count >= 1 Then
                Call RecursiveSubFolders(oSubFolder, sCode, oWB, sCol, sSheetName, rCell)
            End If
        Next oSubFolder
    Else
        Call RecursiveFiles(oFolder, sCode, oWB, sCol, sSheetName, rCell)
    End If
End Sub
Разработка VBA макросы Excel, Word на заказ.
Сказать спасибо на Юмани

5

Re: VBA: Макрос на кнопку, проход по папкам, сравнение с наименованием, со

ivandor421
Если на excelworld форуме, ваше же сообщение и тз, то могу предложить на материальной основе выполнить ваше задание. Можете написать здесь или там в личные сообщения или на почту vbadevelope@yandex.ru, или в группу vk https://vk.com/vbadevelope

Разработка VBA макросы Excel, Word на заказ.
Сказать спасибо на Юмани