Цитирование всех файлов в папке

Question

У меня есть два кода. Я бы хотел, чтобы второй код выполнял первый код для всех файлов в каталоге. Первый код работает как шарм и делает именно то, что мне это нужно, чтобы, в том, что:

Sub STATTRANSFER() 
' Transfers all STATS lines 
Application.ScreenUpdating = False 
Worksheets.Add After:=Worksheets(Worksheets.Count) 
Worksheets(Worksheets.Count).Name = "STATS" 
Set f = Sheets(1) 
Set e = Sheets("Stats") 
Dim d 
Dim j 
Dim k 
d = 1 
j = 1 
k = 1 
Do Until IsEmpty(f.Range("A" & j)) 
    If f.Range("A" & j) = "STATS" Then 
    e.Rows(d).Value = f.Rows(j).Value 
    d = d + 1 
    f.Rows(j).Delete 
    Else 
    j = j + 1 
    End If 
Loop 
Application.ScreenUpdating = True 
End Sub 

второй код выглядит следующим образом:

Public Sub DataProcess() 

Dim folderPath 
Dim filename 
Dim newfilename 
Dim SavePath 
Dim mySubFolder As Object 
Dim mainFolder As Object 
Dim WB As Workbook 
Dim OrigWB As Workbook 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim name1 As String 
Dim name2 As String 

Set OrigWB = ThisWorkbook 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
folderPath = ActiveWorkbook.Path 


Set mainFolder = objFSO.GetFolder(folderPath) 


filename = Dir(folderPath & "*.csv") 

Do While Len(filename) > 0 
    Set WB = Workbooks.Open(folderPath & filename) 
    Call STATTRANSFER 

    ActiveWorkbook.Close SaveChanges:=True 
    filename = Dir 
Loop 



For Each mySubFolder In mainFolder.SubFolders 
    filename = Dir(mySubFolder.Path & "\*.csv*") 
    Do While Len(filename) > 0 
     Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename) 
     Call STATTRANSFER 

     ActiveWorkbook.Close SaveChanges:=True 
     filename = Dir 
    Loop 
Next 
End Sub 

второй код делает успешно петлю через все папки и документы, которые я хочу, но он неправильно выполняет мой первый код. Когда я выполняю первый код только на одном листе, он создает новый лист, называемый STATS, затем берет все строки из первого листа, который имеет слово STATS в столбце A, и копирует их на новый лист, затем удаляет строки STATS из первый лист.

Когда я запускаю его со вторым кодом, который проходит через все папки, он не работает одинаково. Я вижу, что он создает лист, который называется STATS на моем экране, но затем, когда он заканчивается, и я открываю документы, все строки, которые имеют STATS в столбце A, находятся на первом листе, лист STATS больше не существует, и все данные, которые не имеют STATS в столбце A, исчезли. Поэтому я не уверен, в чем проблема.

Answer 1

Держите свой первый суб как есть, заменить второй суб с этим:

Sub MM() 

Dim file  As Variant 
Dim files As Variant 
Dim WB  As Excel.Workbook 

files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".") 

For Each file In files 
    Set WB = Workbooks.Open(file) 
    STATTRANSFER 
    WB.Close True 
    Set WB = Nothing 
Next 

End Sub 

Answer 2

просто как замечание: ваш код работает только через первый уровень вложенных папок. Если вы хотите, чтобы пройти через все папки подуровня, вы должны использовать рекурсивный метод, как:

Private Sub test() 
    readFileSystem ("C:\Temp\") 
End Sub 

Private Sub readFileSystem(ByVal pFolder As String) 
    Dim oFSO As Object 
    Dim oFolder As Object 

    ' create FSO 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 

    ' get start folder 
    Set oFolder = oFSO.getFolder(pFolder) 

    ' list folder content 
    listFolderContent oFolder 

    ' destroy FSO 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub 

Private Sub listFolderContent(ByVal pFolder As Object) 
    Dim oFile As Object 
    Dim oFolder As Object 

    ' go thru all sub folders 
    For Each oFolder In pFolder.SubFolders 
     Debug.Print oFolder.Path 
     ' do the recursion to list sub folder content 
     listFolderContent oFolder 
    Next 

    ' list all files in that directory 
    For Each oFile In pFolder.Files 
     Debug.Print oFile.Path 
    Next 

    ' destroy all objects 
    Set pFolder = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
End Sub 

это всего лишь пример, и вы должны назвать свою первую процедуру курса еще правильным. Поэтому я бы предложил добавить параметр в первую процедуру, где вы можете передать книгу.

и BTW: всегда обрабатывайте переменные с типом данных. Dim j объявит переменную VARIANT, а не Interger, как вы, возможно, захотите.

Answer 3

Вы видите все STATS на первом листе, потому что вы добавили дополнительный лист в файл CSV и сохранили его. По определению CSV-файл сохраняет только 1 лист. Эта модификация вашего кода может решить вашу проблему, так как она вызывает себя для входа в подпапки. Попробуйте. Включите ваш STATTRANSFER sub.

Public Sub DataProcess() 

thisPath = ThisWorkbook.Path 
process_folders (thisPath) 

End Sub 

Sub process_folders(thisPath) 

Dim folderPath 
Dim filename 
Dim newfilename 
Dim SavePath 
Dim mySubFolder As Object 
Dim mainFolder As Object 
Dim WB As Workbook 
Dim OrigWB As Workbook 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim name1 As String 
Dim name2 As String 

Set OrigWB = ThisWorkbook 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
folderPath = ActiveWorkbook.Path 

Set mainFolder = objFSO.GetFolder(folderPath) 
folderPath = ActiveWorkbook.Path 
filename = Dir(folderPath & "\*.csv") 

Do While Len(filename) > 0 
    Set WB = Workbooks.Open(folderPath & "\" & filename) 
    Call STATTRANSFER 

    'save file as Excel file !!! 
    ActiveWorkbook.SaveAs _ 
    filename:=(folderPath & "\" & filename), _ 
    FileFormat:=xlOpenXMLWorkbook, _ 
    CreateBackup:=False 
    ActiveWorkbook.Close (False) 

    filename = Dir 

Loop 

    'now with each subfolder 
    For Each subfolder In mainFolder.SubFolders 
     process_folders (subfolder) 
    Next 

End Sub 

Answer 4

Проблема была в том, что вы можете сохранить CSV с одним листом. Теперь код выглядит следующим образом.

Sub NewDataProcess() 

Dim file  As Variant 
Dim files As Variant 
Dim wb  As Excel.Workbook 

files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".") 

For Each file In files 
    Set wb = Workbooks.Open(file) 
    Call STATTRANSFER(wb) 
    newfilename = Replace(file, ".csv", ".xlsm") 
    wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 
    wb.Close SaveChanges:=False 
    Set wb = Nothing 
Next 

End Sub 

Теперь мне нужен способ удалить старые файлы, если кто-то может с этим помочь. Мне больше не нужен CSV-файл