• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: Výpis souborů adresáře i v podadresářích

Zaslal/a mikar 20.4.2017 10:33

Ahoj všem. Potřebuji poradit, jak napsat ve VBA makro, které mi vypíše doubory v adresáři, ale i v podadresářích např. C:\2017\AAA\, C:\2017\BBB\,C:\2017\CCC\
Tento kod mi vypíše soubory jenom v adresáři C:\2017\
Private Sub vypisadresare()
adresar = "C:\2017\"
ChDir adresar
SouboryKtere = Dir("*.*")
ListBox1.Clear
Do While SouboryKtere <> ""
ListBox1.AddItem SouboryKtere
SouboryKtere = Dir
Loop
Set wshell = CreateObject("WScript.Shell")
MsgBox wshell.CurrentDirectory
End Sub

Díky za radu :-)

Zaslat odpověď >

---

elninoslov(20.4.2017 22:34)#036131

Napr. takto. Kód si dajte do formu, kde máte vytvorený ListBox1.
Dim S(), Pocet As Long

Private Sub UserForm_Initialize()
Dim FSO As Object, fsoAdresar As Object

Const Cesta = "C:\2017\"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoAdresar = FSO.getFolder(Cesta)

Call ZoznamSuborov(fsoAdresar)

Set FSO = Nothing: Set fsoAdresar = Nothing

If Pocet > 0 Then ListBox1.List = S
End Sub

Sub ZoznamSuborov(ByRef fsoAdresar As Object)
Dim fsoSubor As Object, fsoPodAdresar As Object, PocS As Long

With fsoAdresar
PocS = .Files.Count
If PocS > 0 Then
ReDim Preserve S(1 To Pocet + PocS)

For Each fsoSubor In .Files
Pocet = Pocet + 1
S(Pocet) = fsoSubor.Path
Next fsoSubor
End If

For Each fsoPodAdresar In .subFolders
Call ZoznamSuborov(fsoPodAdresar)
Next fsoPodAdresar
End With

Set fsoPodAdresar = Nothing: Set fsoSubor = Nothing
End Sub

Pridávam radšej aj prílohu...

Příloha: 36131_zoznam-vsetkych-suborov-vcetne-podadresarov.zip (15kB, staženo 298x)

citovat

mikar(21.4.2017 7:19)#036132

Výborně. Děkuji moc. Přesně to jsem potřeboval. Funguje to perfektně. Dobrá práce:-)
A jenom takový "skromný" dotaz, šlo by tam někde zakomponovat, aby to vypisovalo jenom určity druh souborů např. sobory které začínají "OBJ" a mají koncovku .xlsm ? Myslím něco jako např.: obj*.xlsm ?citovat

elninoslov(21.4.2017 16:27)#036138

?

Příloha: 36138_zoznam-vsetkych-suborov-vcetne-podadresarov.zip (16kB, staženo 435x)

citovat

mikar(21.4.2017 19:04)#036139

Perfekt:-) Děkuji moc. Funguje to výborně :-) Když se to umí, tak je to brnkačka :-) Ještě jednou díky :-)citovat

pop(7.5.2019 21:17)#043307

Příloha: 36138_zoznam-vsetkych-suborov-vcetne-podadresarov.zip

Ahojte. Jsem úplný amatér a hledal jsem způsob, jak získat soupis skladeb z uložených alb s mp3 soubory. Tato podoba mi vyhovuje, jen bych vytvořený seznam v "ListBoxu" potřeboval dostat do excelovského souboru, abych sním mohl pracovat. Je najěká cesta? Díky Popcitovat

elninoslov(7.5.2019 23:13)#043308

Napr. takto:
Dim S(), Pocet As Long

Sub Zoznam_MP3()
Dim FSO As Object, fsoAdresar As Object, Cesta As String, T()

Pocet = 0 'Výmaz prípadných predošlých výsledkov v poli
Erase S

With wsMP3
Cesta = .Cells(1, 3).Value
If Right$(Cesta, 1) <> "\" Then Cesta = Cesta & "\" 'Kontrola cesty
If Len(Cesta) < 3 Or Len(Dir(Cesta, vbDirectory)) = 0 Then MsgBox "Chybná cesta :" & vbNewLine & Cesta, vbExclamation: Exit Sub

Set FSO = CreateObject("Scripting.FileSystemObject") 'Vytvorenie prístupu k súborom
Set fsoAdresar = FSO.getFolder(Cesta)

Call ZoznamSuborov(fsoAdresar) 'Načítaj prvý adresár

Application.ScreenUpdating = False
With .Columns(1)
.ClearContents 'Vymaž starý zoznam
Select Case Pocet 'Podľa počtu súborov v poli toto pole prevráť cyklom alebo transponuj (nedá sa transponovať viac ako 32767 prvkov)
Case Is > 32767: ReDim T(1 To Pocet, 1 To 1) 'Prevráť
For i = 1 To Pocet
T(i, 1) = S(i)
Next i
.Resize(Pocet).Value = T
Case Is > 0: ReDim Preserve S(1 To Pocet) 'Uprav správnu veľkosť a transponuj
.Resize(Pocet).Value = Application.Transpose(S)
End Select
End With
Application.ScreenUpdating = True

MsgBox "Počet súborov *.mp3 :" & vbNewLine & Pocet, vbInformation
End With

Erase S: Set FSO = Nothing: Set fsoAdresar = Nothing
End Sub

Sub ZoznamSuborov(ByRef fsoAdresar As Object) 'Rekurzívna metóda
Dim fsoSubor As Object, fsoPodAdresar As Object, PocS As Long

With fsoAdresar
PocS = .Files.Count 'Zisti počet súborov v aktuálne skúmanom adresári/podadresári
If PocS > 0 Then
ReDim Preserve S(1 To Pocet + PocS) 'Navýš jednorázovo pole, aj keď nebude využité

For Each fsoSubor In .Files 'Prejdi všetky súbory
If LCase(Right$(fsoSubor.Name, 4)) = ".mp3" Then 'Skontroluj príponu *.mp3
Pocet = Pocet + 1 'Navýš index v poli názvov
S(Pocet) = fsoSubor.Path 'Zapíš cestu súboru
End If
Next fsoSubor
End If

For Each fsoPodAdresar In .subFolders 'Prehľadaj aj prípadné podadresáre
Call ZoznamSuborov(fsoPodAdresar) 'Načítaj podadresár
Next fsoPodAdresar
End With

Set fsoPodAdresar = Nothing: Set fsoSubor = Nothing
End Sub

Příloha: 43308_zoznam-vsetkych-mp3.zip (20kB, staženo 170x)

citovat

pop(8.5.2019 8:20)#043310

Jste neskutečný. Funguje na 1000% podle představy. Díky velmi velmi moc. Před dvaceti lety jsem začal brát Excel trochu vážně a začal jsem s VBA, ale to bylo na úrovni zaznamenávání maker přímo z excelu. V současnoti mám spoustu volného času a rád bych se do toho zase vnořil. Nemůžete mi doporučit publikace, které by byly vhodné jako "učebnice"? Ještě jednou díky moc. citovat

elninoslov(8.5.2019 8:45)#043311

Žiaľ nemám žiadnu literatúru k doporučeniu :(
Ale ani som nehľadal.
Ja som si vo VBA vystačil s netom. Ale zase aké také "programátorské" myslenie som mal naučené ešte z čias Delphi na Pentium I/II, či dokonca z Basicu a Assembleru na PMD-85 :)
Dnes sú určite lepšie možnosti ako kedysi. Takmer na všetko nájdete odpoveď pri zadaní EN dotazu v Googli.
V CZ napr. táto stránka, je tu všetkého mraky. Alebo office.lasakovi.
Z EN napr. stránky rondebruin alebo stackoverflow ...citovat

MePExG(8.5.2019 13:14)#043312

Pomocou PQ (v tabuľke aktualizovať data Ctrl+Alt+F5).

Příloha: 43312_zoznam-suborov.xlsx (22kB, staženo 197x)

citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

Formulář Faktura

Helios iNuvio

On-line nástroje