Добрый день. Макрос работает с файлами из папки. Переписываю программу чтоб не нужно было выбирать папку, а она была бы указана в теле кода, но что-то идёт не так. Запуталась. Нужна ваша помощь
Sub ÏÎÈÑê() Dim iShtName$, iPath$, iFileName$, firstAddress$, a 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 Dim Ïóòü As String, Ôàéë As String Dim Êíèãà As Excel.Workbook
iPath = "D:\Ïîèñê ïî òàáëèöàì\Òàáëèöà" TextToFind = Application.InputBox("Ââåäèòå òåêñò äëÿ ïîèñêà:", "Ïîèñê") If TextToFind = "" Or TextToFind = False Then Exit Sub TextToFind = Trim(TextToFind)
With Workbooks.Open(Filename:=iPath$ & iFileName$) iTempWB = Workbooks.Open(Filename:=iPath & iFileName)
For Each iSheet In iTempWB.Sheets If iSheet.FilterMode = True Then iSheet.ShowAllData
Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlValues, 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).Offset(2) .Value = "Ôàéë: " & iTempWB.Name & ", Ëèñò: " & iSheet.Name .Font.Bold = True End With End If If iFoundRng.MergeCells = True Then ' åñë ÿ÷åéêà îáúåäåíåííàÿ òî iFoundRng.Resize(2, 1).EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Offset(1) ' êîïèðóåì 2 ñòðîêè iShtName = iSheet.Name Else iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) iShtName = iSheet.Name End If End With
Set iFoundRng = iSheet.Cells.FindNext(iFoundRng) ' ïîèñê çíà÷åíèÿ â ýòîì æå ôàéëå íà ýòîì æå ëèñòå If iFoundRng Is Nothing Then Exit Do '
Loop While iFoundRng.Address <> firstAddress
Else End If Next iTempWB.Close saveChanges:=False End With 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 Columns("B:BJ").AutoFit ' ïîäãîíÿåò ñòîëáû ïî øåðíå ñ B äî BJ Columns(1).ColumnWidth = 18 MsgBox "Ïîèñê " & TextToFind & " çàâåðø¸í!", 64, "Ïîèñê"
возможности Dir не совпадают с вашими желаниями подключите \\192.168.0.1.... как диск на локальном компьютере обращайтесь к этому диску по его имени: Х:\...
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!