Страницы: 1
RSS
Работа с файлами из папки
 
Добрый день.
Макрос работает с файлами из папки.
Переписываю программу чтоб не нужно было выбирать папку, а она была бы указана в теле кода, но что-то идёт не так.
Запуталась. Нужна ваша помощь

   
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)


  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$ <> ""
     
     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, "Ïîèñê"
 
End Sub
Изменено: Троица - 09.08.2022 10:33:56
 
возможности Dir не совпадают с вашими желаниями
подключите \\192.168.0.1.... как диск  на локальном компьютере обращайтесь к этому диску по его имени: Х:\...
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Троица,
Страницы: 1
Наверх