Üdvözletem!
Hát eddig elég felemás ez a nyár. Olvastam valahol, hogy nem lehet tudni, ma éppen milyen évszak lesz 🙂
A mai napon az önmagát meghívó makróról lesz szó, amit rekurzív kódnak hívunk. Ennek legegyszerűbb formája a faktoriális kiszámítása (forrás):
|
1 2 3 4 5 6 7 8 9 10 11 |
Function Faktorialis(N) 'pl.: 5!= 1*2*3*4*5 = 120 If N <= 1 Then ' rekurzív hívások végét elértük Faktorialis = 1 'mikor N = 0 Else 'ha N > 0, akkor hívja meg újra és újra önmagát, vagyis a "Faktorialis" függvényt Faktorialis = Faktorialis(N - 1) * N End If End Function |
Ezt a technikát felhasználva ismertetek két kódot, mely egy általunk megadott mappában és annak összes almappájában (és azok almappáiban stb) lévő fájlokat listázza ki. Ez az igény többször felmerül: van egy irtózatosan kusza és bonyolult, Mariana-árok mélységű könyvtárszerkezet és az összes fájlt ki szeretnénk íratni mondjuk egy munkalapra, de ízibe. Itt is két fő igény szokott lenni:
1. Fájlok kilistázása és ún. meta adatok hozzáadása (fájl mérete, típusa vagy létrehozásának dátuma). Print screen:
Az ezt megvalósító VBA kód, magyarázatokkal:
[kód futtatása előtt: referencia hozzáadása a VBA szerkesztõben: Tools > References > “Microsoft Scripting Runtime” elé a pipát betenni, majd “OK”]
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
Sub FajlokListazasaMetaadatokkal() '******************************* 'Fõ kód, csak ezt kell futtatni '******************************* '**************************************************************************************************************** 'kód futtatása elõtt (Korai kötés miatt): referencia hozzáadása a VBA szerkesztõben: _ Tools > References > "Microsoft Scripting Runtime" elé a pipát betenni, majd "OK" '**************************************************************************************************************** 'Inspiráció: _ http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html 'készítette: Tulner Roland (xlmotyo.hu) 'ez a VBA kód a mappában és annak almappáiban lévõ fájlok nevét, teljes elérési útját, valamint néhány metaadatát listázza Dim objFSO As Scripting.FileSystemObject Dim objTopFolder As Scripting.Folder Dim strTopFolderName As String Dim Fejlec() Application.ScreenUpdating = False With Worksheets("Sheet3") '***frissíteni, ha szükséges*** .Select .Cells.Clear End With '-------------------------------------------------------------------------------- 'Legfelsõ mappa hozzárendelése változóhoz strTopFolderName = "d:\Documents\Koltsegvetes(BudgetTracker)\" '***frissíteni*** '--------------------------------------------------------------------------------- 'Fejléc hozzáadása A-F oszlopig Fejlec = Array("Fájlnév", "Fájl mérete", "Fájl típusa", "Létrehozás dátuma", "Utolsó hozzáférés dátuma", _ "Utolsó módosítás dátuma", "Fájl elérési útja") Cells(1, 1).Resize(, UBound(Fejlec) + 1) = Fejlec 'FileSystemObject létrehozása: Dim objFSO As NEW Scripting.FileSystemObject esetén ez a következõ sor nem kellene Set objFSO = CreateObject("Scripting.FileSystemObject") 'Legfelsõ mappa beazonosítása Set objTopFolder = objFSO.GetFolder(strTopFolderName) 'a "RecursiveFolder" makró meghívása Call RecursiveFolder(objTopFolder, True) 'Oszlopok szélességének automatikus beállítása Columns.AutoFit Application.ScreenUpdating = True End Sub Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean) Dim objFile As Scripting.file Dim objSubFolder As Scripting.Folder Dim NextRow As Long 'Következõ üres sor megtalálása NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1 'Menjen végig az összes fájlon a mappában (ciklus) For Each objFile In objFolder.Files Cells(NextRow, "A").Value = objFile.Name Cells(NextRow, "B").Value = objFile.Size Cells(NextRow, "C").Value = objFile.Type Cells(NextRow, "D").Value = objFile.DateCreated Cells(NextRow, "E").Value = objFile.DateLastAccessed Cells(NextRow, "F").Value = objFile.DateLastModified Cells(NextRow, "G").Value = objFile.Path NextRow = NextRow + 1 Next objFile 'Menjen végig az összes fájlon az ALmappákban (ciklus) If IncludeSubFolders Then For Each objSubFolder In objFolder.Subfolders Call RecursiveFolder(objSubFolder, True) Next objSubFolder End If End Sub |
2. Fájlok kilistázása és az elérési út elemeinek szétdobása külön oszlopokba a “\” jel mentén. Print screen:
Az ezt megvalósító VBA kód, szintén magyarázatokkal:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
Sub FajlokListazasaSzetdobassal() '******************************* 'Fõ kód, csak ezt kell futtatni '******************************* 'Inspiráció: _ https://www.thesmallman.com/list-files-in-subdirectory 'készítette: Tulner Roland (xlmotyo.hu) 'ez a VBA kód a mappában és annak almappáiban lévõ fájlokat listázza ki, valamint _ a teljes elérési utat külön oszlopokba dobja szét a "\" mentén Dim sname As Variant Dim sfil(1 To 1) As String Application.ScreenUpdating = False With Worksheets("Sheet4") '***frissíteni, ha szükséges*** .Select .Cells.Clear End With '------------------------------------------------------------------------------- sfil(1) = "d:\Documents\Koltsegvetes(BudgetTracker)\" '***frissíteni*** '------------------------------------------------------------------------------- 'Menjen végig az összes fájlon a mappában (ciklus) For Each sname In sfil() Call SelectFiles(sname) 'a "SelectFiles" makró meghívása Next sname 'Fejléc hozzáadása, igazítása Cells(1, 1) = "Fájl teljes elérési útja" Cells(1, 2) = 1 Cells(1, 2).AutoFill Destination:=Range(Cells(1, 2).Address, Cells(1, ActiveSheet.UsedRange.Columns.Count).Address), Type:=xlFillSeries Cells(1, 1).CurrentRegion.Rows(1).HorizontalAlignment = xlLeft Cells(1, 1).Select Application.ScreenUpdating = True End Sub Private Sub SelectFiles(sPath) 'fájl elérési útja Dim Folder As Object, file As Object, fldr, oFSO As Object, i As Long, Tomb() As String Set oFSO = CreateObject("Scripting.FileSystemObject") 'FileSystemObject létrehozása Set Folder = oFSO.GetFolder(sPath) 'Menjen végig az összes fájlon az ALmappákban (ciklus) For Each fldr In Folder.Subfolders SelectFiles fldr.Path Next fldr 'Menjen végig az összes fájlon a mappában (ciklus) i = 2 For Each file In Folder.Files i = Cells(1, 1).CurrentRegion.Rows.Count + 1 Cells(i, 1).Value = file Tomb = Split(file, "\") 'Fájl elérési útjának szétdobása a "\" mentén Cells(i, 2).Resize(, UBound(Tomb) + 1) = Tomb Next file Set oFSO = Nothing End Sub |
Kérdésed, észrevételed van? Hívj vagy dobj egy emailt az xlmotyo@gmail.com-ra.
