No uvidíme, kto bude mať nervy toto všetko prečítať 
citovat
citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: vba hodnota do vsetkych riadkov
A prečo si to nehodil ty?
citovat
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.
Ked si to hodite do excelu tak to je prehladnejsie. Takto tu to naozaj pôsobý rozsiahlo.citovat
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?
citovatNepoužívajte na všetky info stále GetDetailsOf. Toto trvá iba polku času.
Příloha: 
51453_zoznam-suborov-inak.zip (30kB, staženo 19x)
citovat51453_zoznam-suborov-inak.zip (30kB, staženo 19x)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
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
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
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
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.
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 11x)
citovat51459_zoznam-suborov-inak.zip (33kB, staženo 11x)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
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
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.
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 11x)
citovat51476_zoznam-suborov.zip (31kB, staženo 11x)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.
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 12x)
citovat51479_51476_zoznam-suborov.zip (27kB, staženo 12x)Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
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.
RSS nejnovější články