Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перебор файлов в подпапках
 
#1
02.12.2020 13:07:18
Добрий день!

Есть макрос которий перебирая только файли в папке C:\TMP1 , удаляет  дубли в файле, а нужно еще перебирать и в подпапках, напимер  C:\TMP1\Test
Подправте макрос для перебора в подпапках паки C:\TMP1
Код
Sub uble_rem2()
   Dim Папка$, Имя$
   Dim wb As Workbook
   Dim smallrng As Range
   Dim WS_Count As Integer
   Dim lRow As Long
Dim T As Integer
 
   Application.ScreenUpdating = False
  
   Папка = "C:\TMP1" & "\"
   
      Имя = Dir(Папка & "*.xls")
      
   Do While Имя <> ""
   file = Папка & Имя
   Workbooks.Open file, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
 WS_Count = ActiveWorkbook.Worksheets.Count
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)
 
wb.Sheets(1).Activate
    ActiveWorkbook.Save
    ActiveWorkbook.Close
      Имя = Dir
   Loop
   Application.ScreenUpdating = True
End Sub
 
 
 
#2
02.12.2020 13:31:00
Цитата
sergey2303 написал:
Подправте макрос
Там не подправлять надо, а переписывать. Вот алгоритм, пробуйте адаптировать: Просмотреть все файлы в папке
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#3
02.12.2020 13:50:17
подскажите, а почему ошибка
object required (error 424)
на строке
Код
Set objFolder = objFSO.GetFolder(sPath)
 
 
 
#4
02.12.2020 13:55:55
посмотрите что находится в переменной sPath
убедитесь, что записанный там путь доспупен на вашем компьютере
а еще
убедитесь, что objFSO not is Nothing
Изменено: Ігор Гончаренко - 02.12.2020 13:57:40
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#5
02.12.2020 14:14:09
Код
Sub ruble()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim Папка As String
    Папка = "C:\TMP1" & "\"
    
    uble_rem2 Папка
    
End Sub
'
Sub uble_rem2(ByVal Папка As String)
    Dim Имя$
    Dim wb As Workbook
    Dim smallrng As Range
    Dim WS_Count As Integer
    Dim lRow As Long
    Dim T As Integer
    Dim sfile As String
  
   Application.ScreenUpdating = False
   
   'Папка = "C:\TMP1" & "\"
    
      Имя = Dir(Папка & "*.xls")
       
   Do While Имя <> ""
        sfile = Папка & Имя
        Workbooks.Open sfile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
        WS_Count = ActiveWorkbook.Worksheets.Count
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)
        
        wb.Sheets(1).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Имя = Dir
   Loop
   
    Dim vSubFolder As Variant
    For Each vSubFolder In fso.getFolder(Папка).SubFolders
        uble_rem2 vSubFolder
    Next
   
   Application.ScreenUpdating = True
End Sub
Файла не было -> не тестировал.
 
 
 
#6
02.12.2020 15:01:29
ошибка
Цитата
object required (error 424)
на строке
Код
For Each vSubFolder In fso.getFolder(Папка).SubFolders

тут, пусто
Код
Имя = Dir(Папка & "*.xls")
 
 
 
#7
02.12.2020 15:18:06
Код
Dim fso As Object
'
Sub ruble()
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim Папка As String
    Папка = "C:\TMP1" & "\"
     
    uble_rem2 Папка
     
End Sub
'
Sub uble_rem2(ByVal Папка As String)
    Dim Имя$
    Dim wb As Workbook
    Dim smallrng As Range
    Dim WS_Count As Integer
    Dim lRow As Long
    Dim T As Integer
    Dim sfile As String
   
   Application.ScreenUpdating = False
    
   'Папка = "C:\TMP1" & "\"
   Папка = fso.GetFolder(Папка).Path & "\"
     
      Имя = Dir(Папка & "*.xls")
        
   Do While Имя <> ""
        sfile = Папка & Имя
        Workbooks.Open sfile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
        WS_Count = ActiveWorkbook.Worksheets.Count
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)

        wb.Sheets(1).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Имя = Dir
   Loop
    
    Dim vSubFolder As Variant
    For Each vSubFolder In fso.GetFolder(Папка).SubFolders
        uble_rem2 vSubFolder
    Next
    
   Application.ScreenUpdating = True
End Sub
Тогда так.
Изменено: МатросНаЗебре - 02.12.2020 15:20:03
 
 
 
#8
02.12.2020 15:26:38
Цитата
МатросНаЗебре написал:
Тогда так.
ошибка
object required (error 424)
на строке
Папка = fso.GetFolder(Папка).Path & "\"
 
 
 
#9
02.12.2020 15:30:32
Внёс изменения в код в #7.
 
 
 
#10
02.12.2020 15:43:05
ошибка осталась
object required (error 424)
на строке
Папка = fso.GetFolder(Папка).Path & "\"
 
 
 
#11
02.12.2020 15:48:44
Код
Dim fso As Object
Sub ruble()
    
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim Папка As String
    Папка = "C:\TMP21" & "\"
     
    uble_rem2 Папка
     
End Sub
Sub uble_rem2(ByVal Папка As String)
    Dim Имя$
    Dim wb As Workbook
    Dim smallrng As Range
    Dim WS_Count As Integer
    Dim lRow As Long
    Dim T As Integer
    Dim sfile As String
   
   Application.ScreenUpdating = False
    
   'Папка = "C:\TMP1" & "\"
   If fso.folderexists(Папка) Then
   Папка = fso.GetFolder(Папка).Path & "\"
     
      Имя = Dir(Папка & "*.xls")
        
   Do While Имя <> ""
        sfile = Папка & Имя
        Workbooks.Open sfile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
        WS_Count = ActiveWorkbook.Worksheets.Count
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)        wb.Sheets(1).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Имя = Dir
   Loop
    
    Dim vSubFolder As Variant
    For Each vSubFolder In fso.GetFolder(Папка).SubFolders
        uble_rem2 vSubFolder
    Next
    Else
        MsgBox "Не нашёл папку " & vbCrLf & Папка, vbInformation
    End If
    
   Application.ScreenUpdating = True
End Sub
Скопировать нужно весь код от начала до конца. Недостаточно заменить одну процедуру.
 
 
 
#12
02.12.2020 15:55:34
ошибка осталась
Цитата
object required (error 424)
на строке
Код
If fso.folderexists(Папка) Then
 
 
 
#13
02.12.2020 16:12:18
Код
Sub ruble()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim Папка As String
    Папка = "C:\TMP1" & "\"
     
    uble_rem2 Папка
     
End Sub
Sub uble_rem2(ByVal Папка As String)
    Dim Имя$
    Dim wb As Workbook
    Dim smallrng As Range
    Dim WS_Count As Integer
    Dim lRow As Long
    Dim T As Integer
    Dim sfile As String
   
   Application.ScreenUpdating = False
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
   'Папка = "C:\TMP1" & "\"
   If fso.folderexists(Папка) Then
   Папка = fso.GetFolder(Папка).Path & "\"
     
      Имя = Dir(Папка & "*.xls")
        
   Do While Имя <> ""
        sfile = Папка & Имя
        Workbooks.Open sfile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
        WS_Count = ActiveWorkbook.Worksheets.Count
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)        wb.Sheets(1).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Имя = Dir
   Loop
    
    Dim vSubFolder As Variant
    For Each vSubFolder In fso.GetFolder(Папка).SubFolders
        uble_rem2 vSubFolder
    Next
    Else
        MsgBox "Не нашёл папку " & vbCrLf & Папка, vbInformation
    End If
    
   Application.ScreenUpdating = True
End Sub
А так?
 
 
 
#14
02.12.2020 16:51:40
Так работает
Спасибо
 
 
 
#15
03.12.2020 09:23:20
Предположу, не срабатывало потому, что процедуры помещались в разные модули.
Ниже приведён код, приспособленный для работы в разных модулях, улучшенный в части создания объекта файловой системы.
Код
Public fso As Object

Sub ruble()
    Set fso = CreateObject("Scripting.FileSystemObject")
      
    Dim Папка As String
    Папка = "C:\TMP1" & "\"
      
    uble_rem2 Папка
      
End Sub
Sub uble_rem2(ByVal Папка As String)
    Dim Имя$
    Dim wb As Workbook
    Dim smallrng As Range
    Dim WS_Count As Integer
    Dim lRow As Long
    Dim T As Integer
    Dim sfile As String
    
   Application.ScreenUpdating = False
     
    'Dim fso As Object
    'Set fso = CreateObject("Scripting.FileSystemObject")
     
   'Папка = "C:\TMP1" & "\"
   If fso.folderexists(Папка) Then
   Папка = fso.GetFolder(Папка).Path & "\"
      
      Имя = Dir(Папка & "*.xls")
         
   Do While Имя <> ""
        sfile = Папка & Имя
        Workbooks.Open sfile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
        WS_Count = ActiveWorkbook.Worksheets.Count
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)        wb.Sheets(1).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Имя = Dir
   Loop
     
    Dim vSubFolder As Variant
    For Each vSubFolder In fso.GetFolder(Папка).SubFolders
        uble_rem2 vSubFolder
    Next
    Else
        MsgBox "Не нашёл папку " & vbCrLf & Папка, vbInformation
    End If
     
   Application.ScreenUpdating = True
End Sub
 
 
 
#16
10.12.2020 15:35:40
Цитата
МатросНаЗебре написал:
Предположу, не срабатывало потому, что процедуры помещались в разные модули.Ниже приведён код, приспособленный для работы в разных модулях, улучшенный в части создания объекта файловой системы.
Подскажите, а в это код(пост #15) возможно добавить поиск файла начиная с даты создания, т.е нужно обработать фалы с определенной даты создания
Изменено: sergey2303 - 10.12.2020 16:34:57
 
 
 
#17
10.12.2020 16:28:10
sergey2303, кнопка цитирования не для "вижу, жму, банан получу"... Исправьте сообщение. Если цитирование нужно, то из бездумной копии сделайте ЦИТАТУ
 
 
 
Страницы: 1
Наверх