< návrat zpět

MS Excel

Téma: Vypísanie cesty všetkých súborov rss

Zaslal/a Sperhak 25.2.2021 22:42

Zdravím minule ste mi tu pomohli tak skúsim znova. Cchel by som si spraviť excel na triedenie filmov a trochu to zautomatizovať. Jeden teraz mám hotový ale všetko robím ručne tak by som to chcel vylepšiť. V priloženom exceli na hárku2 je zhruba moja predstava ako by to malo vyzerať. Makro by malo vyťiahnuť cestu k všetkým súborom a potom aj velkosť. Vzorcami v exceli by som si to už tú cestu porozdeloval. No zasekol som sa hned na začiatku. Našiel som si makro ktoré mi čiastočne funguje, ale nedarí sa mi ho upraviť na viac podpriečinkov funguje iba na dva. Tu je pôvodné makro
Sub Example4()

Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String

strDirectory = "D:\cdd\"
i = 1
flag = True
varDirectory = Dir(strDirectory, vbDirectory)

While flag = True
If varDirectory = "" Then

flag = False
Else
Cells(i + 1, 1) = varDirectory
Cells(i + 1, 2) = strDirectory + varDirectory
'returns the next file or directory in the path
varDirectory = Dir
i = i + 1
End If
Wend
End Sub


Takto som sa ho snažil upraviťSub Example4()

Dim varDirectory As Variant
Dim varDirectory2 As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String

strDirectory = "D:\cdd\"
i = 1
flag = True
varDirectory = Dir(strDirectory, vbDirectory)
varDirectory2 = Dir(varDirectory, vbDirectory)

While flag = True
If varDirectory = "" Then

flag = False
Else
Cells(i + 1, 3) = strDirectory + varDirectory + varDirectory2
'returns the next file or directory in the path
varDirectory = Dir
varDirectory2 = Dir
i = i + 1
End If
Wend
End Sub


Neviem ako opísať problém proste to nejde viac do hlbky chcel som tam pridať dalšiu čast a potom dalšiu ale už tá prvá mi nešla.Proste vypíše to len
D:\cdd\Filmy
a malo by to vypísať
D:\cdd\Filmy\Kukurica\Kukurica.txt

Příloha: zip49957_test.zip (15kB, staženo 18x)
Zaslat odpověď >
elninoslov(26.2.2021 0:35)#049959
elninoslov
To nebude problém. Vytvoríme rekurzívnu (do seba sa opakovane vnárajúcu) procedúru. Zosumarizujme si čo potrebujete:
A - celá cesta k súboru
B - veľkosť súboru
C, D, E, F, ... postupne toľko stĺpcov koľko je podadresárov, každý stĺp jeden podadresár ???citovat
Sperhak(26.2.2021 9:01)#049961
avatar
No celu cestu k súboru potrebujem nato aby som si vedel v stlpcoch C D vytiahnut vzorcami informacie lebo vo vba by to bolo pre mna moc komplikovane. Cesta by vyzerala
D:\Filmy\Kukurica\Kukurica.txt
D:\viac dielne filmy\Avengers\black panter.txt
Do D potrebujem prvy priečinok napr. Filmy
Disky budem mat 2 a neviem či písmeno disku je spolahlive že sa priradi vždy k tomu disku tak by som chcel aby sa čital názov disku ale to musim zisťit ci vie vba prečitať to by šlo do C
Do E
Samotny film bez pripony
Ešte som rozmyšlal že by sa tam dalo dať rozlíšenie filmu ale to som ešte nehladal len ma to v noci napadlo, tak ak budem za pc pozriem či to vba dokáže vytiahnuť.citovat
veny(26.2.2021 10:41)#049963
avatar
A co použít Power Query?
Na listu SetupFolder si zadejte cestu ze které složky chcete tahat data a na Listu1 se po aktualizaci zobrazí výpis všech souborů včetně velikost v kB a cesty.

Aktualizace-> na kartě Data - Aktualizovat vše.
Pravděpodobně by se muselo ještě poupravit dle přesných požadavků
Příloha: xlsx49963_pq_vypissouboru.xlsx (26kB, staženo 18x)
citovat
Sperhak(26.2.2021 11:09)#049964
avatar
Našiel som spôsob ako čítať názov disku je v module 2
Dotazy mi nikdy nefungovali správne vždy to nejak sekalo a nešlo to. Skúšal som ten čo si mi poslala ale nejak nechce načitavať údaje.
Ja sa s tým ešte pohrám a dám vedieť lebo ešte sám nemám premyslené ako by som to vlastne chcel.
Příloha: zip49964_test.zip (17kB, staženo 12x)
citovat
Sperhak(26.2.2021 16:35)#049973
avatar
Tak som znova niečo skúsil a ten modul 3 mi dáva všetky informácie v takom tvare ako by som chcel, len tam treba zadať kompletnú cestu k súboru nevyhladá súbory sám.
Teraz ma čaká skombinovať všetky tri moduly čo tam mám nejak do jedného. S tým budem asi potrebovať pomoc.
Příloha: zip49973_test.zip (21kB, staženo 15x)
citovat
Anonym(26.2.2021 19:15)#049980
avatar
Musíš do sebe vnořit ty cykly co procházejí soubory, nějak takhle:

Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim kategorie As Object
Dim film As Object
Dim folder As String

Application.StatusBar = ""
folder = Sheets("Hárok1").Range("A2").Value

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder(folder)
i = 1
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler

For Each kategorie In objFolder.subfolders

For Each film In kategorie.subfolders


Call PrintFiles(film.Path)

Next film
Next kategorie
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
End If
End Sub

Sub PrintFiles(ByVal FolderName As String)
Dim fsObj, FD, Fs, Fl As Object
Dim FullPath, nameoffile As String
Dim Velikost As Long
Dim radek As Long

radI = 2

radek = Sheets("Hárok2").Range("A99999").End(xlUp).Row + 1
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set FD = fsObj.GetFolder(FolderName)
Set Fs = FD.Files

For Each Fl In Fs
nameoffile = Fl.Name

Sheets("Hárok2").Cells(radek, 1) = Fl.Path
Sheets("Hárok2").Cells(radek, 2) = GetProperties(Fl.Path, 0)
Sheets("Hárok2").Cells(radek, 3) = RozdelNazev(Fl.Path, 5)
Sheets("Hárok2").Cells(radek, 4) = GetProperties(Fl.Path, 190)
Sheets("Hárok2").Cells(radek, 5) = GetProperties(Fl.Path, 164)
Sheets("Hárok2").Cells(radek, 6) = GetProperties(Fl.Path, 1)



Next

Set fsObj = Nothing
Set FD = Nothing
Set Fs = Nothing
End Subcitovat
Sperhak(28.2.2021 19:05)#049982
avatar
Dakujem skúšal som a funguje,len s chybičkami.Ak sú v priečinku 2 alebo viac filmov vypíše len jeden. A každým spustením sa hodnoty zapíšu už pod existujúci zoznam čiže tam potom vznikajú duplicity. Vlastne ked som tak rozmýšlal, lepšie by bolo aby sa tie hodnoty čo už v tabulke sú znova neprepisovali a nové sa pridaly naspodok.citovat
longman81(1.3.2021 10:59)#049984
avatar
jo jo stačí připsat aby se při každým spuštění nejdřív vše smazalo, a hledání prázdného řádku dát do cyklu

Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim kategorie As Object
Dim film As Object
Dim folder As String

Sheets("Hárok2").Range("A2:F" & Sheets("Hárok2").Range("A99999").End(xlUp).Row).ClearContents
Application.StatusBar = ""
folder = Sheets("Hárok1").Range("A2").Value

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder(folder)
i = 1
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler

For Each kategorie In objFolder.subfolders

For Each film In kategorie.subfolders


Call PrintFiles(film.Path)

Next film
Next kategorie
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
End If
End Sub

Sub PrintFiles(ByVal FolderName As String)
Dim fsObj, FD, Fs, Fl As Object
Dim FullPath, nameoffile As String
Dim Velikost As Long
Dim radek As Long

radI = 2


Set fsObj = CreateObject("Scripting.FileSystemObject")
Set FD = fsObj.GetFolder(FolderName)
Set Fs = FD.Files

For Each Fl In Fs
radek = Sheets("Hárok2").Range("A99999").End(xlUp).Row + 1
nameoffile = Fl.Name

Sheets("Hárok2").Cells(radek, 1) = Fl.Path
Sheets("Hárok2").Cells(radek, 2) = GetProperties(Fl.Path, 0)
Sheets("Hárok2").Cells(radek, 3) = RozdelNazev(Fl.Path, 5)
Sheets("Hárok2").Cells(radek, 4) = GetProperties(Fl.Path, 190)
Sheets("Hárok2").Cells(radek, 5) = GetProperties(Fl.Path, 164)
Sheets("Hárok2").Cells(radek, 6) = GetProperties(Fl.Path, 1)



Next

Set fsObj = Nothing
Set FD = Nothing
Set Fs = Nothing
End Subcitovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje