Необходимо чтобы файлы, находящиеся в одной папке (и подпапках) с рабочей книгой, находились по маске и копировались в отдельную директорию.
Нижеприведенный код, копирует все файлы с подпапок (чьи имена взяты с отдельной колонки, 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
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
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
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]
Всем здравствуйте,
Необходимо чтобы файлы, находящиеся в одной папке (и подпапках) с рабочей книгой, находились по маске и копировались в отдельную директорию.
Нижеприведенный код, копирует все файлы с подпапок (чьи имена взяты с отдельной колонки, 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
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
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
а какой код чтобы скопировать найденные файлы по маске? например такой в таком коде: [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]
Код
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
If f.Name Like sFile Then '???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ??? ' Указываем Файл исходный = "путь/имя" strSourceFile = strSourcePath & strCurrentFile 'Указываем цель = "новый путь /имя" strTargetFile = strTargetPath & strCurrentFile 'выполняем FileCopy strSourceFile, strTargetFile End If
If f.Name Like sFile Then '???СКОПИРОВАТЬ НАЙДЕННЫЕ ФАЙЛЫ в НОВУЮ ДИРЕКТОРИЮ??? ' Указываем Файл исходный = "путь/имя" strSourceFile = strSourcePath & strCurrentFile 'Указываем цель = "новый путь /имя" strTargetFile = strTargetPath & strCurrentFile 'выполняем FileCopy strSourceFile, strTargetFile End If