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

MS Excel

Téma: vba hodnota do vsetkych riadkov

Zaslal/a Sperhak 3.11.2021 11:17

Zdravím, niekto mi tu kedysi napísal makro na vytiahnutie súborov z disku a zapísanie ich ako zoznam do excelu. Potreboval by som ešte aby sa hodnota názov disku tak isto zapísala do každého riadka tak ako ostatné údaje teraz sa zapíše iba do jednej bunky. prikladám kód.
Dim objFSO As Object, objShell As Object
Dim Info()
Dim CountFiles As Long
Dim Hárok As String

Sub PrintFolders2() 'testovaci
Dim folder As String, bPrint As Boolean
Hárok = "zdroj Axagon n.o 2" 'názov hárku na ktorom sa má spustit makro


folder = Sheets(Hárok).Range("J2").Value 'pismeno disku
'kontrola správnosti cesty ak je zle zadana cesta k disku
If Len(folder) = 0 Then
GoTo FOLDER_ERROR
ElseIf Len(folder) = 1 Then
folder = folder & ":"
End If
folder = Left$(folder, Len(folder) - IIf(Right$(folder, 1) = "\", 1, 0))
If Len(Dir(folder, vbDirectory)) = 0 Then GoTo FOLDER_ERROR

'vymazanie starých dát
Sheets(Hárok).Range("C2:I2").Resize(Sheets(Hárok).Cells(Rows.Count, "C").End(xlUp).Row).ClearContents
Sheets(Hárok).Range("A3:B3").Resize(Sheets(Hárok).Cells(Rows.Count, "C").End(xlUp).Row).ClearContents

'ziksanie nazvu disku
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Sheets(Hárok).Range("I2") = objFSO.GetDrive(objFSO.GetDriveName(folder)).VolumeName
CountFiles = 0
Erase Info()

On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler

'rekurzívne volanie prechádzania adresárov
GetFiles objFSO.GetFolder(folder)
bPrint = CountFiles > 0
GoTo END_PROC

FOLDER_ERROR:
MsgBox "Zle zadane pismeno disku!", vbExclamation
GoTo END_PROC

handleCancel:
If Err = 18 Then
If CountFiles > 0 Then bPrint = MsgBox("You cancelled." & vbNewLine & vbNewLine & "You want to write a partial result ?", vbQuestion + vbYesNo) = vbYes
End If

END_PROC:
' stlpec
If bPrint Then Sheets(Hárok).Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(CountFiles, 6).Value = Application.Transpose(Info): Sheets(Hárok).Activate

Sheets(Hárok).Range("A2:B2").AutoFill Sheets(Hárok).Range("A2:B" & Sheets(Hárok).Range("C" & Rows.Count).End(xlUp).Row) 'vzorce potiahne potial pokial su udaje
'Call Module3.zdroj_do_tabulka 'spusti makro na kopirovanie do tabulky

Set objFSO = Nothing: Set objShell = Nothing: Set objFSO = Nothing: Erase Info()
End Sub

Sub GetFiles(ByRef objFolder As Object)
Dim obj As Object, vFile, Count As Long, radek As Long
If Len(Dir(objFolder.Path, vbDirectory)) = 0 Then Exit Sub
Count = objFolder.Files.Count
If Count > 0 Then 'ak sú nejaké súbory tak zväčši pole výsledkov
radek = CountFiles
CountFiles = CountFiles + Count
ReDim Preserve Info(3 To 8, 1 To CountFiles) 'od akeho po aky stlpec

'prejdi súbory v adresári
With objShell.Namespace(objFolder.Path)
For Each obj In objFolder.Files
radek = radek + 1
Info(8, radek) = obj.Path 'cesta k suboru
Set vFile = .ParseName(obj.Name)
Info(6, radek) = .GetDetailsOf(vFile, 0) 'nazov s priponou
Info(7, radek) = .GetDetailsOf(vFile, 190) 'priecinok v ktorom je subor
Info(5, radek) = .GetDetailsOf(vFile, 164) 'pripona
Info(3, radek) = .GetDetailsOf(vFile, 1) 'velkost
Info(4, radek) = .GetDetailsOf(vFile, 27) 'dĺžka filmu
Next obj
End With
End If

'prejdi podadresáre a volaj znovu rekurzívnu metódu
For Each obj In objFolder.SubFolders
GetFiles obj
Next obj

Set obj = Nothing: Set vFile = Nothing
End Sub



Potreboval by som aby tento kus kodu, vytahoval udaje do kazdeho riadka v stlpci I pokial tam sú údaje. 'ziksanie nazvu disku
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Sheets(Hárok).Range("I2") = objFSO.GetDrive(objFSO.GetDriveName(folder)).VolumeName
CountFiles = 0
Erase Info()
Dúfam že ma chápete. Ked nie pýtajte sa :D Dakujem vopred za pomoc.

Zaslat odpověď >

---

Strana:  1 2 3   další »

marjankaj(3.11.2021 20:03)#051450

No uvidíme, kto bude mať nervy toto všetko prečítať citovat

Sperhak(3.11.2021 20:18)#051451

Ked si to hodite do excelu tak to je prehladnejsie. Takto tu to naozaj pôsobý rozsiahlo.citovat

marjankaj(3.11.2021 20:22)#051452

Sperhak napsal/a:

Ked si to hodite do excelu tak to je prehladnejsie. Takto tu to naozaj pôsobý rozsiahlo.

A prečo si to nehodil ty? citovat

elninoslov(4.11.2021 8:57)#051453

Nepoužívajte na všetky info stále GetDetailsOf. Toto trvá iba polku času.

Příloha: 51453_zoznam-suborov-inak.zip (30kB, staženo 18x)

citovat

Sperhak(4.11.2021 10:41)#051454

elninoslov ďakujem funguje mi to, len som si to trochu upravil.
Vrátil som tam späť GetDetailsOf pretože ten spôsob čo ste spravili vy mi tam dáva aj nejaké súbory čo na disku nemám. Možno nejaké skryté alebo niečo a nevedel som ako sa toho zbaviť.
Chcem tomu trošku aj porozumieť aby som sa dobudúcna nepýtal, ak by si bol ochotný mi to vysvetliť mal by som pár otázok.
Prečo je Set WS = ThisWorkbook.Worksheets("zdroj Axagon n.o 2") lepšie ako to čo som mal ja? je tam nejaký rozdiel?citovat

elninoslov(4.11.2021 18:17)#051458

To WS som tam dal hlavne pre zjednodušenie zápisu. Mne sa to tak lepšie číta. Rozdiel v rýchlosti v tomto prípade bude 0. Ak by ale išlo o veľké množstvo operácii s Worksheets(Hárok), bolo by WS ako premenná rýchlejšie.

GetDetailsOf je pomalé. Nevidím dôvod, prečo zisťovať príponu alebo adresár súboru pomocou GetDetailsOf ???
Skúšal som to na rôznych typoch súboru, dátových, skladieb, videí od adresárov 500 MB až po cca 500 GB. A všade bolo pôvodné makro o 100-150% pomalšie. Minimálne!

Prechádzanie súborov ako takých som neriešil, teda nieje žiadny dôvod, prečo by Vám malo makro ukázať iné súbory. Nič také nepozorujem, ja mám výsledky rovnaké.citovat

Sperhak(4.11.2021 18:55)#051459

Posielam súbor ako to je na druhom hárku som skopíroval tak ako mi to dá pôvodné makro a na tom prvom je to vaše.

Mal by som ešte jednu otázku. Dá sa spraviť to že
Set WS = ThisWorkbook.Worksheets("zdroj Axagon n.o 2")
spolu s ostatnýmy budem mať zadefinované zvlášt na jednom module a potom by ostatné moduly brali tieto informácie z neho?
Boloby tam takto zadefinovaných viac hárkov, či takto sa to nerobi? Pretože mám viac modulov ktoré využívajú ten istý zošit a ked ho premenujem tak to musím spraviť v každom a takto by mi to stačilo len v tom jednom.
Dúfam že ste ma pochopily.

Příloha: 51459_zoznam-suborov-inak.zip (33kB, staženo 10x)

citovat

elninoslov(5.11.2021 8:04)#051465

Problém a riešenie sú jednoduché.
Problém:
Tento riadok v pôvodnom kóde kontroluje existenciu adresára. To je v poriadku, takto to používam aj ja. Ale nie v parametrizovanej procedúre, kde je vstupný parameter priamo objekt adresára. Teda je jasné, že adresár existuje, keď do procedúry vstupuje ako objekt (teda overený). Preto som tento riadok, ktorý v tomto prípade robí duplicitné overenie existencie, odstránil. Keďže ale Dir() používa parameter vbDirectory, tak vbHidden neberie. Preto sa cez tento riadok nedostane "System Volume Information" (systémový skrytý adresár). Odbočka - ak by ste niekedy potreboval, aby cez Len(Dir()) prešiel aj skrytý adresár použite parameter vbDirectory + vbHidden. Takže odstránením tohto riadku z kódu sa skrytý adresár dostane ďalej na spracovanie.
If Len(Dir(objFolder.Path, vbDirectory)) = 0 Then Exit Sub
Riešenie:
Je jednoduché. Vo volacom rekurzívnom cykle použijeme vylúčenie skrytých adresárov:
Namiesto
GetFiles obj
použijeme
If Not obj.Attributes And 2 Then GetFiles obj
a skrytý adresár ani len nevstúpi do procedúry.

Čo si ale treba sekundárne uvedomiť je, že takto môžeme mať v neskrytom adresári skrytý súbor. A ten nám vypíšu obe verzie makra. Logicky. Takže to eliminujeme tak, že aj v cykle čítania súborov dáme overenie atribútu Hidden:
For Each obj In objFolder.Files
radek = radek + 1
...
Next obj
doplníme
For Each obj In objFolder.Files
If obj.Attributes And 2 Then
CountHidden = CountHidden + 1
Else
radek = radek + 1
...
End If
Next obj
If CountHidden > 0 Then CountFiles = CountFiles - CountHidden: ReDim Preserve Info(3 To 8, 1 To CountFiles) 'oprava väčšieho poľa pri Hiddencitovat

Sperhak(5.11.2021 16:56)#051476

Dakujem za úpravu spravil som ju a funguje. Len som si nie istý týmto riadkom či ho mám vymazať.
If Len(Dir(objFolder.Path, vbDirectory)) = 0 Then Exit Sub
Posielam súbor a prosím skontrolovali by ste či to mám dobre a je tam aj označený ten riadok, neviem či ho zmazať alebo nie.

Příloha: 51476_zoznam-suborov.zip (31kB, staženo 10x)

citovat

elninoslov(6.11.2021 1:05)#051479

V procedúre GetFiles ten riadok s Dir() už byť nemá. Naopak som tam ja zabudol dať ešte deklaráciu premennej CountHidden
CountHidden as Long
Pre lepšiu čitateľnosť kódu ešte odporúčam zarovnať vždy na rovnakú úroveň tabulátorom začiatok a koniec konkrétneho cyklu For-Next, priradenia With-End With, alebo podmienky If-Else-End If.

No a čo tie prvé 2 stĺpce, to nechcete radšej tiež v tom makre urobiť? Príde mi zbytočné následné rozkopírovanie vzorcov.

Příloha: 51479_51476_zoznam-suborov.zip (27kB, staženo 11x)

citovat

Strana:  1 2 3   další »

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse