0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
|
||||||
1 | ||||||
Excel Макрос поиска значений по разным файлам Excel23.11.2018, 08:51. Показов 5279. Ответов 7
Есть такой макрос:
Вопрос. Как сделать так, чтобы макрос после поиска значения ячейки "С2" во всех файлах, заново начал поиск, только уже значения в ячейке "С3" также по всем файлам? Т.е. Другими словами зациклить функцию поиска в макросе, меняя значение переменной после каждого ее выполнения начиная с "С2", потом "С3""С4""С5" и так например до "С200"Просто нужно выполнить поиск 247 значений по всем файлам, и не хочется 247 раз вручную менять значение ячейки "C2". Заранее спасибо!
0
|
23.11.2018, 08:51 | |
Ответы с готовыми решениями:
7
Макрос для поиска значений на листе Макрос для поиска и подстановки значений перебором Макрос для поиска текста в PDF и копирования в excel Макрос поиска вводимого значения и ввода вводимых значений в соседнии ячейки |
Заблокирован
|
|
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 |
Остап Бонд, держите
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" (создайте такой, если нет в книге) выделите диапазон со значениями (скопировать сможете?) и запустите вашей кнопкой. Код с колена и без проверки (сильно не пинайте, если что)
1
|
0 / 0 / 0
Регистрация: 07.12.2017
Сообщений: 5
|
|
23.11.2018, 15:54 [ТС] | 8 |
Остап Бонд, Спасибо огромное!!! Проблема решена! Проверяет сразу по всем файлам весь заданный диапазон!
0
|
23.11.2018, 15:54 | |
23.11.2018, 15:54 | |
Помогаю со студенческими работами здесь
8
Помогите пожалуста написать макрос поиска по листу в EXCEL. Cценарий такой:... Макрос, чтобы другой макрос распихал сам по N файлам Макрос всевозможных перестановок значений ячеек /Excel Макрос на дублирование строк в Excel с заменой некоторых значений Искать еще темы с ответами Или воспользуйтесь поиском по форуму: |