< návrat zpět

MS Excel

Téma: vba hodnota do vsetkych riadkov rss

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:  « předchozí  1 2 3   další »
Sperhak(6.11.2021 10:30)#051480
avatar
Dakujem za kontrolu a úpravu. To s tým tabom viem že je to prehladnejšie a keď si to píšem ja tak to robím, ale nie vždy pochopím ak kód takto skopírujem od niekoho a hlavne ked je zložitejší, ktoré if začína a ktoré end ho ukončuje.

K tým dvom vzorcom, takto som to vedel spraviť ja. Do makra by som to nevedel zakomponovať. Ak sa vám chce môžte to skúsiť dať do makra a ak by ste mohli pridať k jednotlivým riadkom poznámky tak ako tam už v niektorých riadkoch mám. Chcel by som to pochopiť ako to bude fungovať.citovat
Sperhak(7.11.2021 10:04)#051482
avatar
Dnes som chcel otestovat rýchlost tých dvoch rozdielnych spôsobov na mojom disku kde mám filmy doteraz som to robil len na testovacom usb a ten nový spôsom, posledný súbor ktorý ste mi poslali nefunguje. Nic sa nedeje chybu to neukáže ked som skúšal krokovať F8 tak vnorovanie fungovalo ale do konca sa to nedá odsledovat kde sa to zasekne. Na tom usb to funguje možno je chyba v mnozstve udajov?citovat
elninoslov(7.11.2021 12:08)#051483
elninoslov
Tu som urobil aj nejaký popis + drobné úpravy makra. Tento Váš príspevok som si prečítal až po tom, čo som to dokončil, každopádne mne to funguje, aj na USB (root aj adresár) aj na internom HDD (root aj adresár).
Ešte premýšľam, či by sa dalo (a či by sa mi chcelo), celé to prekopať tak, že by si najskôr urobilo zoznam súborov (možno kolekcia aj s objektami súborov/adresárov, možno len pole súborov urobené rovnakým spôsobom len bez načítavania informácií). Až následne by sa v druhom kole načítavali informácie o súboroch. Získame počet súborov na spracovanie a môžeme zobraziť progres. No na rýchlosti ale stratíme 2x. Raz duplicitným cyklom a raz spomaľovaním pri vypisovaní progresu. No získame prehľad.
O koľkých súboroch a akej celkovej veľkosti sa tu väčšinou bavíme? Nech si to skúsim nasimulovať.
Příloha: zip51483_zoznam-suborov.zip (30kB, staženo 9x)
citovat
Sperhak(7.11.2021 13:03)#051484
avatar
Dakujem idem sa na to pozrieť. Prekopanie nebude treba progress nepotrebujem. S tým mojím spôsobom mi to trvalo cca 15s čo je pre mna prijatelné. Excel tam síce nachvílu vytuhne, potom sa ale spametá a dokončí sa to.
Ten váš spôsob mi žial na disku nefunguje neviem kde môže byť chyba. Posielam zatial moju finálnu verziu, ostatné makrá si nevšímajte nech vás to nemetie.
Na hárkoch zdroj Axagon sú údaje vytiahnuté z disku aby ste mali predstavu o kolkých položkách sa bavíme.
Příloha: zip51484_vypis-info-o-filmoch-v0.17.zip (426kB, staženo 9x)
citovat
elninoslov(7.11.2021 13:28)#051485
elninoslov
No a kým som urobil progres, napíšete, že ho netreba 5
Neva skúste. Neskôr pozriem aj na ten Váš súbor.
Příloha: zip51485_zoznam-suborov.zip (33kB, staženo 10x)
citovat
elninoslov(7.11.2021 17:41)#051487
elninoslov
Takže to makro parametrizujeme, pže ho potrebujete spúšťať na inom liste/disku. To že ste povedal z iného modulu, to vyznie úplne inak. To nebude problém.
Počet zdrojov je známy a nemenný?
Každý zdroj/disk má svoj list?
Ak sa jeden zdroj aktualizuje (teda sa spustí makro na jeho liste), ako sa aktualizuje tá tabuľka "zdroj spojené"? vymazať sa nemôže, to by sa museli aktualizovať všetky zdroje. Dalo by sa vyhľadať/vyfiltrovať iba podľa mena zdroju/disku/partície a vymazať iba tie, a pridať aktualizované...
No a načo je potom tá Tabuľka "Tabuľka1" na liste Tabulka? To sú už vlastne triplicitné dáta. Dávala by zmysel, ak by sa pomocou PowerQuery z nej robil ten zoznam na liste Filmy. No tu je problém, že si tam značíte manuálnym podfarbením asi čo ste videl, alebo vlastné hodnotenie, alebo neviem čo, a to by Vám po akejkoľvek aktualizácii nesedelo. Pže po pridaní jediného filmu by sa to zoradilo, ale iba dáta, nie podfarbenia. Riešením by bolo asi jedine, toto značenie robiť v ten súhrnnej tabuľke/Tabuľke v nejakom pridanom stĺpci, napr. hodnotenie 1..5, alebo V - videl. A to by sa premietlo do Podmieneného Formátovania pri danom filme, nech by bol zoradený kdekoľvek. ALE. Museli by byť vytvorené jedinečné identifikátory v tejto tabuľke/Tabuľke (napr. jedinečné číslo, ktoré by sa neopakovalo, ani po zmazaní záznamu). Prečo? Lebo sa film môže volať rovnako, a pritom pôjde o niečo iné. ALE. Toto tiež skrachuje na aktualizácii PQ.

Myslím, že niektoré veci, ktoré chcete dosiahnuť, mi zapínajú. Ale bude to možno komplikovanejšie, ak si zatiaľ myslíte.
Tiež mám zbierku, a ako pribúdali komplikácie katalogizácie, tak som sa to vysr...kašľal, a teraz mám krásny nefalšovaný chaos a neviem nič nájsť 2citovat
Sperhak(8.11.2021 8:35)#051490
avatar
No skúsim to zobrať po bodoch:
1.Nemyslím si že to bude jednoduché, pre mna je to nemožné a niekto iný sa mi stým zadarmo babrať nebude asi ani vy.
2.Bolo by to najlepšie tak ako popisujete. Mal by som taký podfarbený zoznam, po aktualizovaný by sa tam pridali nové filmy a podfarbovanie a poznámky by ostali a neprehádzali sa.Ale viem že je to nemožné a od toho som dávno upustil ešte než som sa opýtal prvú otázku.
3.Značím si tam kvalitu filmu, ale to asi nieje tak podstatné.
4.hárok zdroj spojené sa aktualizuje modulom4 makrom spoj_zdroje proste sa vymaže a údaje sa tam znova nakopírujú, nemusí sa znova čítať z disku.
5.To z iného modulu som myslel tak že napr na moduly1 a 4 musím mať napísané Set WS = ThisWorkbook.Worksheets("zdroj Axagon")
a v prípade premenovania hárku to musím premenovať na oboch, ale to ste mi už ukázali v poslednom súbore ako to spraviť inak.
6. Tabulka tam asi je navyše, proste som len skúšal ako by to vyzeralo najlepšie, čo sa mi najviac páči. Teraz som dospel k záveru že prvé 2 hárky mi vyhovujú a tabulku asi vymažem aj ten posledný hárok.

Snád som zodpovedal všetko.
Za ten progress ďakujem hovorím že byť nemusí, ale ked už je tak poteší.

Robíme to čoraz komplikovanejšie a vytvárame nové chyby tento posledný súbor mi po spustení makra píše permision denied, ale zasa iba ak to skúšam na hdd ak to skúšam z usb kde mám málo údajov,ale zasa žiadny film iba také testovacie podpriečinky tak tam funguje
A súbor predtým sa len tvári že niečo robí ale nespraví nič.citovat
elninoslov(9.11.2021 8:44)#051496
elninoslov
Zatiaľ málo času, ale prišiel som na zaujímavé veci.
Uvádzam príklad toho, čo dám načítať v objFSO.GetFolder a aký adresár skutočne dostanem:
"c:" - "C:\Program Files\Microsoft Office\root\Office16".
"d:" - "D:\Dokumenty"
"e:" - "E:\Download"
a keď tam nechám lomítko \:
"c:\" - "C:\"
"d:\" - "D:\"
"e:\" - "E:\"
sranda čo? To lomítko tam musí byť! Neviem, prečo sme ho dávali vtedy preč, asi podľa požiadavky vzhľadu.

Teraz k chybe. Tá vzniká pri načítaní disku a určovaní veľkosti spracovávaných dát.
Ak spracovávame adresár vieme určiť jeho veľkosť (kvôli progresu)
CelkVelkost = objFolder.Size
ale ak sa jedná o root
tak táto vlastnosť neexistuje, a veľkosť obsadených dát potrebujeme vypočítať na základe kapacity a voľného miesta
CelkVelkost = objFolder.Drive.TotalSize - objFolder.Drive.FreeSpace
takže
If objFolder.IsRootFolder Then CelkVelkost = objFolder.Drive.TotalSize - objFolder.Drive.FreeSpace Else CelkVelkost = objFolder.Size

Nad ďalšími vecami musím najskôr porozmýšľať a mať na to čas. Ale to s tým označovaním farbou asi nepôjde...
Příloha: zip51496_zoznam-suborov.zip (34kB, staženo 10x)
citovat
Sperhak(10.11.2021 19:38)#051513
avatar
Ked pripojím disk vyskúšam. Ked to však robilo to že sa odtstranovalo to lomitko netsačilo by vymazať tento riadok
Case Else: Folder = Left$(Folder, Len(Folder) - IIf(Right$(Folder, 1) = "\", 1, 0)) 'odstránenie posledného lomítka
či program zasa potrebuje niekde aj cestu bez lomítka?citovat
Sperhak(12.11.2021 6:28)#051533
avatar
Získavanie údajov už funguje aj na diskoch, ukazuje sa progress a excel nevytuhne pri získavaní údajov takže aj vizuálne plus ďakujem.
Potreboval by som ďalšiu pomoc, tým že sme odstránili vzorce sú v hárkoch Zdroj Axagon v stĺpci A nejaké prázdne bunky tým pádom mi Range(Selection, Selection.End(xlDown)).Selectskočí len po ne a ostatne údaje neoznačí. Je to v Module4 má to spojiť údaje z 2 diskov do jedného veľkého zoznamu.
Ak by sa to nedalo nejak jednoducho tak sa vrátim k tým vzorcom a tým pádom tam bude údaj a bude to fungovať.
Příloha: zip51533_vypis-info-o-filmoch-v0.17.zip (240kB, staženo 10x)
citovat

Strana:  « předchozí  1 2 3   další »

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