Форум программистов, компьютерный форум, киберфорум
VBA
Форум программистов и сисадминов Киберфорум > Форум программистов > Basic > VBA
Войти
Регистрация
Восстановить пароль
Карта форума Темы раздела Блоги Сообщество Поиск Заказать работу  
 
Рейтинг 4.52/25: Рейтинг темы: голосов - 25, средняя оценка - 4.52
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
1
Excel

Макрос поиска значений по разным файлам Excel

23.11.2018, 08:51. Показов 4975. Ответов 7
Метки excel, vba, макросы (Все метки)
Author24 — интернет-сервис помощи студентам
Есть такой макрос:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

Option Explicit
 
Dim FSO As Object, iFolder As Object, iFile As Object, FD As FileDialog, ExtArray() As Variant
Dim iPath As String, firstAddress As String, iPathName As String, Recursion As Boolean
Dim iSht As Worksheet, iReportSht As Worksheet, iTempWB As Workbook, ExcelVersion As Byte
Dim TextToFind As Variant, iFoundRng As Range, iLastRow As Long, FoundAny As Boolean, iTotalFiles As Long
 
Sub ÏîèñêÂîÂñåõÔàéëàõÈÏàïêàõ()
'Ïîèñê òåêñòà âî âñåõ Excel ôàéëàõ íà âñåõ ëèñòàõ â óêàçàííîé ïàïêå
'10/10/2008; 07/04/2010
 
    Recursion = False: iPathName = "": FoundAny = False
    TextToFind = Trim(Worksheets("Ëèñò1").Range("C2").Value)
    If TextToFind = "" Or TextToFind = False Then Exit Sub
    TextToFind = Trim(TextToFind)
 
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Óêàæèòå íóæíóþ äèðåêòîðèþ"
        .ButtonName = "Âûáðàòü ïàïêó"
        If .Show = False Then Exit Sub Else iPath = .SelectedItems(1) & Application.PathSeparator
    End With
    Set FD = Nothing
 
    If MsgBox("Ïðîñìàòðèâàòü âëîæåííûå ïàïêè?", vbQuestion + vbYesNo, "Ðåêóðñèÿ") = vbYes Then Recursion = True
 
    Set iReportSht = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    With iReportSht
        .Name = "Îò÷¸ò"
        With .Cells(1, 1)
            .Value = "Ïîèñê òåêñòà: " & """" & TextToFind & """"
            .Font.Bold = True
        End With
    End With
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
        .ShowWindowsInTaskbar = False
 
        On Error GoTo ErrHandler:
        ExcelVersion = Val(Application.Version)
        ExtArray = Array("xls", "xlsx", "xlsm", "xlsb", "csv")    'çäåñü ìîæíî óêàçàòü, êàêèå ðàñøèðåíèÿ áóäåì îáðàáàòûâàòü
        Set FSO = CreateObject("Scripting.FileSystemObject")
        ChooseFoldersSubfoldersFSO (iPath)
        Set iFolder = Nothing
        Set FSO = Nothing
        iReportSht.Cells(2, 1).Select
 
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
    If FoundAny = False Then
        MsgBox "Òåêñò '" & TextToFind & "' íè â îäíîì èç ôàéëîâ â ïàïêå:" & Chr(10) & "'" & iPath & "'" & " íå áûë íàéäåí!" _
             & Chr(10) & "Âñåãî áûëî îáðàáîòàíî: " & iTotalFiles & " ôàéëîâ", 48, "Îò÷¸ò"
        iReportSht.Parent.Close SaveChanges:=False
        Exit Sub
    End If
    MsgBox "Ïîèñê çàâåðø¸í!" & Chr(10) & "Âñåãî îáðàáîòàíî: " & iTotalFiles & " ôàéëîâ", 64, "Ïîèñê"
    Exit Sub
 
ErrHandler:
    If Err <> 0 Then MsgBox "Ïðîèçîøëà íåïðåäâèäåííàÿ îøèáêà: " & Err.Number & Chr(10) & Err.Description, 48, "Îøèáêà"
    With Application
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
 
Function ChooseFoldersSubfoldersFSO(ByVal Papka As String)
 
    Set iFolder = FSO.GetFolder(Papka)
    For Each iFile In iFolder.Files
        If Not IsError(Application.Match(FSO.GetExtensionName(iFile), ExtArray(), 0)) Then
            If CanOpenFile = True Then
                If iFile.Name <> ThisWorkbook.Name Then
                    Set iTempWB = Workbooks.Open(Filename:=Papka & iFile.Name, UpdateLinks:=False, ReadOnly:=True)
                    iTotalFiles = iTotalFiles + 1
                    Application.StatusBar = "Ïîèñê â: " & iTempWB.FullName
                    For Each iSht In iTempWB.Worksheets
                        If iSht.FilterMode = True Then iSht.ShowAllData
                        Set iFoundRng = iSht.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                        If Not iFoundRng Is Nothing Then
                            FoundAny = True
                            firstAddress = iFoundRng.Address
                            Do
                                With iReportSht
                                    iLastRow = .UsedRange.Rows.Count + .UsedRange.Row
                                    If iPathName <> Papka Then  'åñëè íîâûé ôàéë
                                        iPathName = Papka
                                        With .Cells(iLastRow + 2, 1)
                                            .Value = "Äèðåêòîðèÿ: " & Papka
                                            .Font.Bold = True
                                        End With
                                        .Hyperlinks.Add Anchor:=.Cells(iLastRow + 3, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name, TextToDisplay:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name
                                        With .Cells(iLastRow + 3, 1)
                                        End With
                                    Else
                                        .Hyperlinks.Add Anchor:=.Cells(iLastRow + 1, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name, TextToDisplay:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name
                                        With .Cells(iLastRow + 1, 1)
                                        End With
                                    End If
                                    iFoundRng.EntireRow.Copy   'êîïèðóåì âñþ ñòðîêó
                                    .Cells(.UsedRange.Rows.Count + .UsedRange.Row, "A").PasteSpecial xlPasteValues    'âñòàâëÿåì òîëüêî çíà÷åíèÿ
                                End With
                                Set iFoundRng = iSht.Cells.FindNext(iFoundRng)
                            Loop While iFoundRng.Address <> firstAddress
                        End If
                    Next
                    Application.CutCopyMode = False
                    iTempWB.Close SaveChanges:=False
                End If
            End If
        End If
    Next
 
    If Recursion Then    'ðåêóðñèÿ
        For Each iFolder In iFolder.SubFolders
            ChooseFoldersSubfoldersFSO iFolder.Path & Application.PathSeparator
        Next
    End If
End Function
 
Function CanOpenFile() As Boolean
'ïðîâåðÿåì, ìîæåì ëè ìû îòêðûòü äàííîå ðàñøèðåíèå ôàéëà â òåêóùåé âåðñèè Excel
    'åñëè Excel âåðñè 2007 è âûøå
    If ExcelVersion >= 12 Then CanOpenFile = True: Exit Function
    'åñëè Excel âåðñè 2003 è íèæå
    If ExcelVersion < 12 And FSO.GetExtensionName(iFile) = "xls" Then CanOpenFile = True
End Function
Он берет значение ячейки "С2" и ищет его во всех файлах Excel из указанных мной папок, подпапок.

Вопрос. Как сделать так, чтобы макрос после поиска значения ячейки "С2" во всех файлах, заново начал поиск, только уже значения в ячейке "С3" также по всем файлам? Т.е. Другими словами зациклить функцию поиска в макросе, меняя значение переменной после каждого ее выполнения начиная с "С2", потом "С3""С4""С5" и так например до "С200"Просто нужно выполнить поиск 247 значений по всем файлам, и не хочется 247 раз вручную менять значение ячейки "C2". Заранее спасибо!
0
Лучшие ответы (1)
Сообщение: #13087173
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
 23.11.2018, 08:51
Ответы с готовыми решениями:

Макрос для поиска значений на листе
Помогите написать макрос в Excel Смысл макроса примерно такой. В книги есть листы где каждый лист...

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

Макрос для поиска текста в PDF и копирования в excel
добрый день! посталена вот такая задача, хотел бы ей как-то автоматизировать, что можете...

Макрос поиска вводимого значения и ввода вводимых значений в соседнии ячейки
Есть такая таблица (это пример и текст там примерный, для образца). Первый столбец пронумерован от...

7
Заблокирован
23.11.2018, 09:27 2
ItBSM, скопируйте свой код в тему при включенной RU-раскладке, голову сносит при виде такого.

Добавлено через 5 минут
По поводу самого алгоритма - каждый из файлов вы хотите открывать по 200 раз для каждого из 200 значений?
На садо-мазо похоже.
Меняйте подход, открыли файл, перебрали ячейки с2:с200, перешли к следующему файлу (зачем издеваться над собой и железом?).
1
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
23.11.2018, 10:09  [ТС] 3
Остап Бонд, Если можно и сразу так перебрать то хорошо. Только знать бы как это реализовать..

Добавлено через 3 минуты
Остап Бонд,


Option Explicit

Dim FSO As Object, iFolder As Object, iFile As Object, FD As FileDialog, ExtArray() As Variant
Dim iPath As String, firstAddress As String, iPathName As String, Recursion As Boolean
Dim iSht As Worksheet, iReportSht As Worksheet, iTempWB As Workbook, ExcelVersion As Byte
Dim TextToFind As Variant, iFoundRng As Range, iLastRow As Long, FoundAny As Boolean, iTotalFiles As Long

Sub ÏîèñêÂîÂñåõÔàéëàõÈÏàïêàõ()
'Ïîèñê òåêñòà âî âñåõ Excel ôàéëàõ íà âñåõ ëèñòàõ â óêàçàííîé ïàïêå
'10/10/2008; 07/04/2010

Recursion = False: iPathName = "": FoundAny = False
TextToFind = Trim(Worksheets("Ëèñò1").Range("C2").Value)
If TextToFind = "" Or TextToFind = False Then Exit Sub
TextToFind = Trim(TextToFind)

Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.AllowMultiSelect = False
.Title = "Óêàæèòå íóæíóþ äèðåêòîðèþ"
.ButtonName = "Âûáðàòü ïàïêó"
If .Show = False Then Exit Sub Else iPath = .SelectedItems(1) & Application.PathSeparator
End With
Set FD = Nothing

If MsgBox("Ïðîñìàòðèâàòü âëîæåííûå ïàïêè?", vbQuestion + vbYesNo, "Ðåêóðñèÿ") = vbYes Then Recursion = True

Set iReportSht = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
With iReportSht
.Name = "Îò÷¸ò"
With .Cells(1, 1)
.Value = "Ïîèñê òåêñòà: " & """" & TextToFind & """"
.Font.Bold = True
End With
End With

With Application
.ScreenUpdating = False
.Calculation = xlManual
.EnableEvents = False
.ShowWindowsInTaskbar = False

On Error GoTo ErrHandler:
ExcelVersion = Val(Application.Version)
ExtArray = Array("xls", "xlsx", "xlsm", "xlsb", "csv") 'çäåñü ìîæíî óêàçàòü, êàêèå ðàñøèðåíèÿ áóäåì îáðàáàòûâàòü
Set FSO = CreateObject("Scripting.FileSystemObject")
ChooseFoldersSubfoldersFSO (iPath)
Set iFolder = Nothing
Set FSO = Nothing
iReportSht.Cells(2, 1).Select

.StatusBar = False
.ShowWindowsInTaskbar = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

If FoundAny = False Then
MsgBox "Òåêñò '" & TextToFind & "' íè â îäíîì èç ôàéëîâ â ïàïêå:" & Chr(10) & "'" & iPath & "'" & " íå áûë íàéäåí!" _
& Chr(10) & "Âñåãî áûëî îáðàáîòàíî: " & iTotalFiles & " ôàéëîâ", 48, "Îò÷¸ò"
iReportSht.Parent.Close SaveChanges:=False
Exit Sub
End If
MsgBox "Ïîèñê çàâåðø¸í!" & Chr(10) & "Âñåãî îáðàáîòàíî: " & iTotalFiles & " ôàéëîâ", 64, "Ïîèñê"
Exit Sub

ErrHandler:
If Err <> 0 Then MsgBox "Ïðîèçîøëà íåïðåäâèäåííàÿ îøèáêà: " & Err.Number & Chr(10) & Err.Description, 48, "Îøèáêà"
With Application
.StatusBar = False
.ShowWindowsInTaskbar = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Function ChooseFoldersSubfoldersFSO(ByVal Papka As String)

Set iFolder = FSO.GetFolder(Papka)
For Each iFile In iFolder.Files
If Not IsError(Application.Match(FSO.GetExtensionName(iFile), ExtArray(), 0)) Then
If CanOpenFile = True Then
If iFile.Name <> ThisWorkbook.Name Then
Set iTempWB = Workbooks.Open(Filename:=Papka & iFile.Name, UpdateLinks:=False, ReadOnly:=True)
iTotalFiles = iTotalFiles + 1
Application.StatusBar = "Ïîèñê â: " & iTempWB.FullName
For Each iSht In iTempWB.Worksheets
If iSht.FilterMode = True Then iSht.ShowAllData
Set iFoundRng = iSht.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
If Not iFoundRng Is Nothing Then
FoundAny = True
firstAddress = iFoundRng.Address
Do
With iReportSht
iLastRow = .UsedRange.Rows.Count + .UsedRange.Row
If iPathName <> Papka Then 'åñëè íîâûé ôàéë
iPathName = Papka
With .Cells(iLastRow + 2, 1)
.Value = "Äèðåêòîðèÿ: " & Papka
.Font.Bold = True
End With
.Hyperlinks.Add Anchor:=.Cells(iLastRow + 3, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name, TextToDisplay:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name
With .Cells(iLastRow + 3, 1)
End With
Else
.Hyperlinks.Add Anchor:=.Cells(iLastRow + 1, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name, TextToDisplay:="Êíèãà: " & iTempWB.Name & ", Ëèñò: " & iSht.Name
With .Cells(iLastRow + 1, 1)
End With
End If
iFoundRng.EntireRow.Copy 'êîïèðóåì âñþ ñòðîêó
.Cells(.UsedRange.Rows.Count + .UsedRange.Row, "A").PasteSpecial xlPasteValues 'âñòàâëÿåì òîëüêî çíà÷åíèÿ
End With
Set iFoundRng = iSht.Cells.FindNext(iFoundRng)
Loop While iFoundRng.Address <> firstAddress
End If
Next
Application.CutCopyMode = False
iTempWB.Close SaveChanges:=False
End If
End If
End If
Next

If Recursion Then 'ðåêóðñèÿ
For Each iFolder In iFolder.SubFolders
ChooseFoldersSubfoldersFSO iFolder.Path & Application.PathSeparator
Next
End If
End Function

Function CanOpenFile() As Boolean
'ïðîâåðÿåì, ìîæåì ëè ìû îòêðûòü äàííîå ðàñøèðåíèå ôàéëà â òåêóùåé âåðñèè Excel
'åñëè Excel âåðñè 2007 è âûøå
If ExcelVersion >= 12 Then CanOpenFile = True: Exit Function
'åñëè Excel âåðñè 2003 è íèæå
If ExcelVersion < 12 And FSO.GetExtensionName(iFile) = "xls" Then CanOpenFile = True
End Function
0
Заблокирован
23.11.2018, 10:12 4
ItBSM, что то ещё хуже стало?
Приложите файл с макросом (в ZIP его, если размер или разрешение не подходит).
1
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
23.11.2018, 10:15  [ТС] 5
Остап Бонд, держите
Вложения
Тип файла: xls post_222774.xls (50.0 Кб, 46 просмотров)
0
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
23.11.2018, 10:16  [ТС] 6
Остап Бонд, Сам макрос будет использован не на этом листе, просто возьмите за основу С2:С200. Спасибо)
0
Заблокирован
23.11.2018, 11:47 7
Лучший ответ Сообщение было отмечено ItBSM как решение

Решение

ItBSM, замените весь код модуля на приложенный ниже (там небольшие изменения, но долго объяснять),
на листе "Лист1" (создайте такой, если нет в книге) выделите диапазон со значениями (скопировать сможете?) и запустите вашей кнопкой. Код с колена и без проверки (сильно не пинайте, если что)

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

Option Explicit
 
Dim FSO As Object, iFolder As Object, iFile As Object, FD As FileDialog, ExtArray() As Variant
Dim iPath As String, firstAddress As String, iPathName As String, Recursion As Boolean
Dim iSht As Worksheet, iReportSht As Worksheet, iTempWB As Workbook, ExcelVersion As Byte
Dim TextToFind As Variant, iFoundRng As Range, iLastRow As Long, FoundAny As Boolean, iTotalFiles As Long
 
Dim a_TextToFind() 'массив значений поиска (выделенный диапазон на Лист1)
 
DIM X'!!!
 
Sub ПоискВоВсехФайлахИПапках()
'Поиск текста во всех Excel файлах на всех листах в указанной папке
'10/10/2008; 07/04/2010
 
    Recursion = False: iPathName = "": FoundAny = False
    
    Dim s1 As Worksheet: Set s1 = ActiveSheet
    Worksheets("Лист1").Activate
    a_TextToFind = Selection.Value
    s1.Activate
    
'    x = "C2"
'    TextToFind = Trim(Worksheets("Лист1").Range(x).Value)
'    If TextToFind = "" Or TextToFind = False Then Exit Sub
'    TextToFind = Trim(TextToFind)
 
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Укажите нужную директорию"
        .ButtonName = "Выбрать папку"
        If .Show = False Then Exit Sub Else iPath = .SelectedItems(1) & Application.PathSeparator
    End With
    Set FD = Nothing
 
    If MsgBox("Просматривать вложенные папки?", vbQuestion + vbYesNo, "Рекурсия") = vbYes Then Recursion = True
 
    Set iReportSht = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    With iReportSht
        .Name = "Отчёт"
        With .Cells(1, 1)
            .Value = "Поиск текста: " & """" & TextToFind & """"
            .Font.Bold = True
        End With
    End With
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
        .ShowWindowsInTaskbar = False
 
        On Error GoTo ErrHandler:
        ExcelVersion = Val(Application.Version)
        ExtArray = Array("xls", "xlsx", "xlsm", "xlsb", "csv")    'здесь можно указать, какие расширения будем обрабатывать
        Set FSO = CreateObject("Scripting.FileSystemObject")
        ChooseFoldersSubfoldersFSO (iPath)
        Set iFolder = Nothing
        Set FSO = Nothing
        iReportSht.Cells(2, 1).Select
 
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
    If FoundAny = False Then
        MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & "'" & iPath & "'" & " не был найден!" _
             & Chr(10) & "Всего было обработано: " & iTotalFiles & " файлов", 48, "Отчёт"
        iReportSht.Parent.Close SaveChanges:=False
        Exit Sub
    End If
    MsgBox "Поиск завершён!" & Chr(10) & "Всего обработано: " & iTotalFiles & " файлов", 64, "Поиск"
    Exit Sub
 
ErrHandler:
    If Err <> 0 Then MsgBox "Произошла непредвиденная ошибка: " & Err.Number & Chr(10) & Err.Description, 48, "Ошибка"
    With Application
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
 
Function ChooseFoldersSubfoldersFSO(ByVal Papka As String)
 
    Set iFolder = FSO.GetFolder(Papka)
    For Each iFile In iFolder.Files
        If Not IsError(Application.Match(FSO.GetExtensionName(iFile), ExtArray(), 0)) Then
            If CanOpenFile = True Then
                If iFile.Name <> ThisWorkbook.Name Then
                    Set iTempWB = Workbooks.Open(Filename:=Papka & iFile.Name, UpdateLinks:=False, ReadOnly:=True)
                    iTotalFiles = iTotalFiles + 1
                    Application.StatusBar = "Поиск в: " & iTempWB.FullName
                    For Each iSht In iTempWB.Worksheets
                        If iSht.FilterMode = True Then iSht.ShowAllData
                        
                        For Each x In a_TextToFind
                          TextToFind = Trim(x)
                          If Not (TextToFind = "" Or TextToFind = False) Then 'Exit Sub
                            TextToFind = Trim(TextToFind)
                        
                            Set iFoundRng = iSht.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                            If Not iFoundRng Is Nothing Then
                                FoundAny = True
                                firstAddress = iFoundRng.Address
                                Do
                                    With iReportSht
                                        iLastRow = .UsedRange.Rows.Count + .UsedRange.Row
                                        If iPathName <> Papka Then  'если новый файл
                                            iPathName = Papka
                                            With .Cells(iLastRow + 2, 1)
                                                .Value = "Директория: " & Papka
                                                .Font.Bold = True
                                            End With
                                            .Hyperlinks.Add Anchor:=.Cells(iLastRow + 3, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Книга: " & iTempWB.Name & ", Лист: " & iSht.Name, TextToDisplay:="Книга: " & iTempWB.Name & ", Лист: " & iSht.Name
                                            With .Cells(iLastRow + 3, 1)
                                            End With
                                        Else
                                            .Hyperlinks.Add Anchor:=.Cells(iLastRow + 1, 1), Address:=Papka & iTempWB.Name, ScreenTip:="Книга: " & iTempWB.Name & ", Лист: " & iSht.Name, TextToDisplay:="Книга: " & iTempWB.Name & ", Лист: " & iSht.Name
                                            With .Cells(iLastRow + 1, 1)
                                            End With
                                        End If
                                        iFoundRng.EntireRow.Copy   'копируем всю строку
                                        .Cells(.UsedRange.Rows.Count + .UsedRange.Row, "A").PasteSpecial xlPasteValues    'вставляем только значения
                                    End With
                                    Set iFoundRng = iSht.Cells.FindNext(iFoundRng)
                                Loop While iFoundRng.Address <> firstAddress
                            End If
                          
                          End If
                        Next x
                    
                    Next
                    Application.CutCopyMode = False
                    iTempWB.Close SaveChanges:=False
                End If
            End If
        End If
    Next
 
    If Recursion Then    'рекурсия
        For Each iFolder In iFolder.SubFolders
            ChooseFoldersSubfoldersFSO iFolder.Path & Application.PathSeparator
        Next
    End If
End Function
 
Function CanOpenFile() As Boolean
'проверяем, можем ли мы открыть данное расширение файла в текущей версии Excel
    'если Excel верси 2007 и выше
    If ExcelVersion >= 12 Then CanOpenFile = True: Exit Function
    'если Excel верси 2003 и ниже
    If ExcelVersion < 12 And FSO.GetExtensionName(iFile) = "xls" Then CanOpenFile = True
End Function
1
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
23.11.2018, 15:54  [ТС] 8
Остап Бонд, Спасибо огромное!!! Проблема решена! Проверяет сразу по всем файлам весь заданный диапазон!
0
23.11.2018, 15:54
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
 23.11.2018, 15:54
Помогаю со студенческими работами здесь

Помогите пожалуста написать макрос поиска по листу в EXCEL. Cценарий такой:...
Есть две книги,надо данние с одной книги найти в другой,взять значение соседней ячейки,перенести...

Макрос, чтобы другой макрос распихал сам по N файлам
Может эта тема уже тут звучала, да поиск не помог... Просто проблема в том, что макрос постоянно...

Макрос всевозможных перестановок значений ячеек /Excel
требуется написать следующий макрос: Для выделенных ячеек строки вывести под ними все возможные...

Макрос на дублирование строк в Excel с заменой некоторых значений
Всем привет! Есть изначальная табличка (она в приложении лист &quot;исходник&quot;); Необходимо чтобы...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
8
Ответ Создать тему
КиберФорум - форум программистов, компьютерный форум, программирование
Поддержать - Реклама - Обратная связь
Powered by vBulletin
Copyright ©2000 - 2024, CyberForum.ru