Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Найти и скопировать в отдельную папку все файлы по маске - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти и скопировать в отдельную папку все файлы по маске (Макросы/Sub)
Найти и скопировать в отдельную папку все файлы по маске
nurgaliev Дата: Понедельник, 08.02.2016, 07:17 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Всем здравствуйте,

Необходимо чтобы файлы, находящиеся в одной папке (и подпапках) с рабочей книгой, находились по маске и копировались в отдельную директорию.

Нижеприведенный код, копирует все файлы с подпапок (чьи имена взяты с отдельной колонки, SubFolder) без учета маски (взятой тоже c колонки, sMask) в папку с именем текстбокса (txt_banum) на рабочий стол пользователя.

Также, создается выборка - таблица фильтруется по txt_banum.Value и копируется на отдельный файл.

Как все же осуществить поиск по маске файлов во всех подпапках (без SubFolder)?

Через FSO пробовал, не получилось =(

[vba]
Код

Private Sub cmd_ok_Click()

Dim sFilesPath As String, sNewPath As String, sMask As String
Dim sFolder As String, sFiles As String, SubFolder As String, sDoc As String
Dim sFile As String

If txt_banum.Text = "" Or Len(txt_banum.Text) < 13 Then
    MsgBox "НЕДОСТАТОЧНО СИМВОЛОВ!", vbCritical
    'Selection.AutoFilter
    Exit Sub
End If

lLastRow = Cells.SpecialCells(xlLastCell).Row

Set iskk = Sheets(2).Range("A:A").Find(txt_banum.Text, lookat:=xlWhole)

If Not iskk Is Nothing Then
ActiveSheet.Range("$A$1:$D$" & lLastRow).AutoFilter Field:=1, Criteria1:=txt_banum.Text

Range("$A$1:$D$" & lLastRow).Copy
Sheets("CurrData").Cells.Delete
Selection.Copy Sheets("CurrData").Range("A1")
Sheets("CurrData").Columns("A:D").ColumnWidth = 20

Selection.AutoFilter
Dim username1
Dim path As String

username1 = Environ("USERNAME")
path = "C:\Users" & "" & username1 & "" & "Desktop" & "" & txt_banum.Value
check = Dir(path & Application.PathSeparator, vbDirectory)

With ThisWorkbook.Sheets("CurrData")
        If Len(check) > 0 Then
        MsgBox ("Папка " & txt_banum.Value & " уже существует")
        Else
        MkDir path
        End If
        NewPath = path & Application.PathSeparator & "Summary" & ".xlsx"
        ThisWorkbook.Sheets("CurrData").Copy
        ActiveWorkbook.SaveAs (NewPath)
        ActiveWorkbook.Close
End With
ThisWorkbook.Activate

sNewPath = path & Application.PathSeparator 'куда перемещать файлы

Application.ScreenUpdating = False
        kon = Sheets("CurrData").Range("I10000").End(xlUp).Row
            'kona = Sheets("CurrData").Range("C10000").End(xlUp).Row
        For i = 2 To kon
            SubFolder = Sheets("CurrData").Cells(i, 9).Value
            sDoc = Sheets("CurrData").Cells(i, 3).Value

sFilesPath = ThisWorkbook.path & "" & SubFolder & Application.PathSeparator 'откуда перемещать файлы
sMask = sDoc

    sFolder = sFilesPath
    sFiles = Dir(sFolder)
    
    Do While sFiles <> ""
        If InStr(sFiles, sMask) < 2 Then
    
            FileCopy sFolder & Application.PathSeparator & sFiles, sNewPath & Application.PathSeparator & sFiles
        End If
        sFiles = Dir
    Loop

    Application.ScreenUpdating = True
Next

txt_banum.Value = ""
MsgBox "Пакет документов создан в директории " & path

uf_main.Hide

Selection.AutoFilter

        Else: MsgBox "Номер не Найден!", vbCritical
        Sheets("CurrData").Cells.Delete
        Sheets(2).Select
        lLastRow = Cells.SpecialCells(xlLastCell).Row
        End If

End Sub
[/vba]


Сообщение отредактировал nurgaliev - Понедельник, 08.02.2016, 07:18
 
Ответить
СообщениеВсем здравствуйте,

Необходимо чтобы файлы, находящиеся в одной папке (и подпапках) с рабочей книгой, находились по маске и копировались в отдельную директорию.

Нижеприведенный код, копирует все файлы с подпапок (чьи имена взяты с отдельной колонки, SubFolder) без учета маски (взятой тоже c колонки, sMask) в папку с именем текстбокса (txt_banum) на рабочий стол пользователя.

Также, создается выборка - таблица фильтруется по txt_banum.Value и копируется на отдельный файл.

Как все же осуществить поиск по маске файлов во всех подпапках (без SubFolder)?

Через FSO пробовал, не получилось =(

[vba]
Код

Private Sub cmd_ok_Click()

Dim sFilesPath As String, sNewPath As String, sMask As String
Dim sFolder As String, sFiles As String, SubFolder As String, sDoc As String
Dim sFile As String

If txt_banum.Text = "" Or Len(txt_banum.Text) < 13 Then
    MsgBox "НЕДОСТАТОЧНО СИМВОЛОВ!", vbCritical
    'Selection.AutoFilter
    Exit Sub
End If

lLastRow = Cells.SpecialCells(xlLastCell).Row

Set iskk = Sheets(2).Range("A:A").Find(txt_banum.Text, lookat:=xlWhole)

If Not iskk Is Nothing Then
ActiveSheet.Range("$A$1:$D$" & lLastRow).AutoFilter Field:=1, Criteria1:=txt_banum.Text

Range("$A$1:$D$" & lLastRow).Copy
Sheets("CurrData").Cells.Delete
Selection.Copy Sheets("CurrData").Range("A1")
Sheets("CurrData").Columns("A:D").ColumnWidth = 20

Selection.AutoFilter
Dim username1
Dim path As String

username1 = Environ("USERNAME")
path = "C:\Users" & "" & username1 & "" & "Desktop" & "" & txt_banum.Value
check = Dir(path & Application.PathSeparator, vbDirectory)

With ThisWorkbook.Sheets("CurrData")
        If Len(check) > 0 Then
        MsgBox ("Папка " & txt_banum.Value & " уже существует")
        Else
        MkDir path
        End If
        NewPath = path & Application.PathSeparator & "Summary" & ".xlsx"
        ThisWorkbook.Sheets("CurrData").Copy
        ActiveWorkbook.SaveAs (NewPath)
        ActiveWorkbook.Close
End With
ThisWorkbook.Activate

sNewPath = path & Application.PathSeparator 'куда перемещать файлы

Application.ScreenUpdating = False
        kon = Sheets("CurrData").Range("I10000").End(xlUp).Row
            'kona = Sheets("CurrData").Range("C10000").End(xlUp).Row
        For i = 2 To kon
            SubFolder = Sheets("CurrData").Cells(i, 9).Value
            sDoc = Sheets("CurrData").Cells(i, 3).Value

sFilesPath = ThisWorkbook.path & "" & SubFolder & Application.PathSeparator 'откуда перемещать файлы
sMask = sDoc

    sFolder = sFilesPath
    sFiles = Dir(sFolder)
    
    Do While sFiles <> ""
        If InStr(sFiles, sMask) < 2 Then
    
            FileCopy sFolder & Application.PathSeparator & sFiles, sNewPath & Application.PathSeparator & sFiles
        End If
        sFiles = Dir
    Loop

    Application.ScreenUpdating = True
Next

txt_banum.Value = ""
MsgBox "Пакет документов создан в директории " & path

uf_main.Hide

Selection.AutoFilter

        Else: MsgBox "Номер не Найден!", vbCritical
        Sheets("CurrData").Cells.Delete
        Sheets(2).Select
        lLastRow = Cells.SpecialCells(xlLastCell).Row
        End If

End Sub
[/vba]

Автор - nurgaliev
Дата добавления - 08.02.2016 в 07:17
al-Ex Дата: Понедельник, 08.02.2016, 08:55 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 59 ±
Замечаний: 0% ±

Excel 2010
Как все же осуществить поиск по маске файлов во всех подпапках
тут смотрел?
Список файлов в папке
 
Ответить
Сообщение
Как все же осуществить поиск по маске файлов во всех подпапках
тут смотрел?
Список файлов в папке

Автор - al-Ex
Дата добавления - 08.02.2016 в 08:55
nurgaliev Дата: Понедельник, 08.02.2016, 09:10 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
тут смотрел?
Список файлов в папке


а какой код чтобы скопировать найденные файлы по маске?
например такой в таком коде:
[vba]
Код

Public Sub Main()
    Dim fso As New Scripting.FileSystemObject
    
    FindFileInFolder fso.GetFolder("C:\Program Files\Far"), "*adm*.*"
End Sub

Private Sub FindFileInFolder(ff As Folder, sFile As String)
    Dim fo As Scripting.Folder, f As Scripting.File

    For Each f In ff.Files
        If f.Name Like sFile Then ???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
    Next f
    For Each fo In ff.SubFolders
        FindFileInFolder fo, sFile
    Next fo
End Sub
[/vba]
 
Ответить
Сообщение
тут смотрел?
Список файлов в папке


а какой код чтобы скопировать найденные файлы по маске?
например такой в таком коде:
[vba]
Код

Public Sub Main()
    Dim fso As New Scripting.FileSystemObject
    
    FindFileInFolder fso.GetFolder("C:\Program Files\Far"), "*adm*.*"
End Sub

Private Sub FindFileInFolder(ff As Folder, sFile As String)
    Dim fo As Scripting.Folder, f As Scripting.File

    For Each f In ff.Files
        If f.Name Like sFile Then ???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
    Next f
    For Each fo In ff.SubFolders
        FindFileInFolder fo, sFile
    Next fo
End Sub
[/vba]

Автор - nurgaliev
Дата добавления - 08.02.2016 в 09:10
al-Ex Дата: Понедельник, 08.02.2016, 09:51 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 59 ±
Замечаний: 0% ±

Excel 2010
If f.Name Like sFile Then
???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
тут смотри.
Введение в объектную модель FSO
или если без наворотов FSO, то так, примерно:
[vba]
Код

If f.Name Like sFile Then '???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
' Указываем Файл исходный = "путь/имя"
strSourceFile = strSourcePath & strCurrentFile
'Указываем цель = "новый путь /имя"
strTargetFile = strTargetPath & strCurrentFile
'выполняем
  FileCopy strSourceFile, strTargetFile
End If
[/vba]


Сообщение отредактировал al-Ex - Понедельник, 08.02.2016, 11:00
 
Ответить
Сообщение
If f.Name Like sFile Then
???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
тут смотри.
Введение в объектную модель FSO
или если без наворотов FSO, то так, примерно:
[vba]
Код

If f.Name Like sFile Then '???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ???
' Указываем Файл исходный = "путь/имя"
strSourceFile = strSourcePath & strCurrentFile
'Указываем цель = "новый путь /имя"
strTargetFile = strTargetPath & strCurrentFile
'выполняем
  FileCopy strSourceFile, strTargetFile
End If
[/vba]

Автор - al-Ex
Дата добавления - 08.02.2016 в 09:51
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти и скопировать в отдельную папку все файлы по маске (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!