Добрый вечер дамы и господа Наткнулся на макрос поиска по группе Excel файлов по заданному слову/цифре: [vba]
Код
Option Explicit Sub Поиск() Dim iShtName$, iPath$, iFileName$, firstAddress$ Dim iSheet As Worksheet, iFoundSht As Worksheet Dim iTempWB As Workbook, iBazaWB As Workbook Dim TextToFind As Variant, iFoundRng As Range Dim FD As FileDialog, iLastRow& Dim FoundAny As Boolean TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск") If TextToFind = "" Or TextToFind = False Then Exit Sub TextToFind = Trim(TextToFind) Set FD = Application.FileDialog(msoFileDialogFilePicker) With FD .AllowMultiSelect = False .Title = "Укажите любой файл в папке" .ButtonName = "Выбрать папку" If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\")) End With Set FD = Nothing Workbooks.Add Sheets.Add.Name = "Поиск" Set iFoundSht = ActiveSheet iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind iFoundSht.Cells(1, 1).Font.Bold = True With Application .ScreenUpdating = False .Calculation = xlManual .StatusBar = "Идёт поиск..." .ShowWindowsInTaskbar = False iFileName = Dir(iPath & "*.xls*") Do While iFileName$ <> "" Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True) For Each iSheet In iTempWB.Sheets If iSheet.FilterMode = True Then iSheet.ShowAllData Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart) If Not iFoundRng Is Nothing Then FoundAny = True firstAddress = iFoundRng.Address Do With iFoundSht iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If iLastRow = 1 Then iLastRow = 2 If iShtName <> iSheet.Name Then With .Cells(iLastRow + 2, 1) .Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name .Font.Bold = True End With End If iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) iShtName = iSheet.Name End With Set iFoundRng = iSheet.Cells.FindNext(iFoundRng) Loop While iFoundRng.Address <> firstAddress Else End If Next iTempWB.Close SaveChanges:=False iFileName = Dir Loop .StatusBar = False .ShowWindowsInTaskbar = True .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With If FoundAny = False Then MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт" iFoundSht.Parent.Close SaveChanges:=False Exit Sub End If MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск" 'Range("A:T" & Range("A" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=SUM(R[-14]C:R[-1]C)" 'Selection.AutoFill Destination:=("A" & Rows.Count), Type:=xlFillDefault 's = Range("A:T" & Rows.Count).End(xlUp).Row 'Cells(s + 1, 1) = "=SUM(R[-14]C:R[-1]C)" End Sub
[/vba] Данный код не работает, если искомое слово находится в строке с незаполненной первой ячейкой (она же "A"). Т.е. во вложенном примере - слово "щеб" не найдётся из-за пустой ячейки "A482") И отвечают за эту беду эти строки: [vba]
[/vba] Пытался через Range, но вдруг не всё заполнено и понапрасну пускать поиск в пустые ячейки. А вот бы по поиску последней заполненной ячейке... Ммммм
(Мне как раз надо найти последнюю заполненную строку и чуть ниже просуммировать всё то, что лежит выше по соответствующему столбцу. Т.е. на примере: "A140:S140" A140=СУММ(A1:A139) , B140=СУММ(B1:B139) и т.д. до последнего заполненного столбца (здесь "S").)
Добрый вечер дамы и господа Наткнулся на макрос поиска по группе Excel файлов по заданному слову/цифре: [vba]
Код
Option Explicit Sub Поиск() Dim iShtName$, iPath$, iFileName$, firstAddress$ Dim iSheet As Worksheet, iFoundSht As Worksheet Dim iTempWB As Workbook, iBazaWB As Workbook Dim TextToFind As Variant, iFoundRng As Range Dim FD As FileDialog, iLastRow& Dim FoundAny As Boolean TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск") If TextToFind = "" Or TextToFind = False Then Exit Sub TextToFind = Trim(TextToFind) Set FD = Application.FileDialog(msoFileDialogFilePicker) With FD .AllowMultiSelect = False .Title = "Укажите любой файл в папке" .ButtonName = "Выбрать папку" If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\")) End With Set FD = Nothing Workbooks.Add Sheets.Add.Name = "Поиск" Set iFoundSht = ActiveSheet iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind iFoundSht.Cells(1, 1).Font.Bold = True With Application .ScreenUpdating = False .Calculation = xlManual .StatusBar = "Идёт поиск..." .ShowWindowsInTaskbar = False iFileName = Dir(iPath & "*.xls*") Do While iFileName$ <> "" Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True) For Each iSheet In iTempWB.Sheets If iSheet.FilterMode = True Then iSheet.ShowAllData Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart) If Not iFoundRng Is Nothing Then FoundAny = True firstAddress = iFoundRng.Address Do With iFoundSht iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If iLastRow = 1 Then iLastRow = 2 If iShtName <> iSheet.Name Then With .Cells(iLastRow + 2, 1) .Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name .Font.Bold = True End With End If iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) iShtName = iSheet.Name End With Set iFoundRng = iSheet.Cells.FindNext(iFoundRng) Loop While iFoundRng.Address <> firstAddress Else End If Next iTempWB.Close SaveChanges:=False iFileName = Dir Loop .StatusBar = False .ShowWindowsInTaskbar = True .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With If FoundAny = False Then MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт" iFoundSht.Parent.Close SaveChanges:=False Exit Sub End If MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск" 'Range("A:T" & Range("A" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=SUM(R[-14]C:R[-1]C)" 'Selection.AutoFill Destination:=("A" & Rows.Count), Type:=xlFillDefault 's = Range("A:T" & Rows.Count).End(xlUp).Row 'Cells(s + 1, 1) = "=SUM(R[-14]C:R[-1]C)" End Sub
[/vba] Данный код не работает, если искомое слово находится в строке с незаполненной первой ячейкой (она же "A"). Т.е. во вложенном примере - слово "щеб" не найдётся из-за пустой ячейки "A482") И отвечают за эту беду эти строки: [vba]
[/vba] Пытался через Range, но вдруг не всё заполнено и понапрасну пускать поиск в пустые ячейки. А вот бы по поиску последней заполненной ячейке... Ммммм
(Мне как раз надо найти последнюю заполненную строку и чуть ниже просуммировать всё то, что лежит выше по соответствующему столбцу. Т.е. на примере: "A140:S140" A140=СУММ(A1:A139) , B140=СУММ(B1:B139) и т.д. до последнего заполненного столбца (здесь "S").)Yar4i
[/vba]Во первых, проверка идет по столбцу А - Range("A" & Rows.Count), аон почти весь пустой, во вторых в Range("A:T" & Range("A" & Rows.Count)... строка определяется только для столбца Т, а для А нет. В третьих, формуле R[-14] это на 14 строк выше, то есть суммироваться будут строки 139 и 139-14=125. Попробуйте такую химию: [vba]
[/vba]Во первых, проверка идет по столбцу А - Range("A" & Rows.Count), аон почти весь пустой, во вторых в Range("A:T" & Range("A" & Rows.Count)... строка определяется только для столбца Т, а для А нет. В третьих, формуле R[-14] это на 14 строк выше, то есть суммироваться будут строки 139 и 139-14=125. Попробуйте такую химию: [vba]
Спасибо. По первой ячейке ищет последнюю. И в случае пустой "A" ставит там формулу, не смотря на то что в "B:T" могут быть символы//цифры. С рабочего кода перенёс это, но вижу только Debug [vba]
[/vba] здесь он ищет последнюю пустую по "D" и заполняет формулой строку от "A" до "T". Но как заставить искать по массиву "A:D" ?
Все коды просмотрел - поиск по массиву не нашел рабочий. А если сначала найти самый нижний заполненный столбец NS, а потом этот столбец использовать в [vba]
Спасибо. По первой ячейке ищет последнюю. И в случае пустой "A" ставит там формулу, не смотря на то что в "B:T" могут быть символы//цифры. С рабочего кода перенёс это, но вижу только Debug [vba]
[/vba] здесь он ищет последнюю пустую по "D" и заполняет формулой строку от "A" до "T". Но как заставить искать по массиву "A:D" ?
Все коды просмотрел - поиск по массиву не нашел рабочий. А если сначала найти самый нижний заполненный столбец NS, а потом этот столбец использовать в [vba]
боялся этого вопроса, но надо найти текст во всех файлах, согласно темы. В скобках добавил схожую беду встречающуюся в приложенном коде. Не могу найти возможность поиска последней строки по целому массиву, а не по одному столбцу.
боялся этого вопроса, но надо найти текст во всех файлах, согласно темы. В скобках добавил схожую беду встречающуюся в приложенном коде. Не могу найти возможность поиска последней строки по целому массиву, а не по одному столбцу.Yar4i
Ну не определена у вас переменная, Dim iRow. Замените на iLastRow. И вот еще код, определяет самую последнюю заполненную строку именно в диапазоне столбцов A:D [vba]
Ну не определена у вас переменная, Dim iRow. Замените на iLastRow. И вот еще код, определяет самую последнюю заполненную строку именно в диапазоне столбцов A:D [vba]
Наверное не стыкуется поиск всех занятых ячеек с поисковым запросом, в данном случае "щебень". В первом листе итог макроса. Наше всё и почему-то первая ячейка не пуста.
Наверное не стыкуется поиск всех занятых ячеек с поисковым запросом, в данном случае "щебень". В первом листе итог макроса. Наше всё и почему-то первая ячейка не пуста.Yar4i
и споткнулся! Не бывает готового макроса, что бы без вмешательства подошел к какой то задаче. В любом случае, конкретный макрос надо подгонять к конкретной таблице. Вот и у этого, малость другая задача. К вашей задаче его надо подгонять или переделывать.
и споткнулся! Не бывает готового макроса, что бы без вмешательства подошел к какой то задаче. В любом случае, конкретный макрос надо подгонять к конкретной таблице. Вот и у этого, малость другая задача. К вашей задаче его надо подгонять или переделывать.Wasilich