< návrat zpět
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.
elninoslov(12.11.2021 6:42)#051535 
Prílohu som ešte nepozeral. Mám rozpracované to čo som spomínal. Bude to ukladať disk priamo do spoločnej tbl, s tým že nahradí predchádzajúce údaje z disku s rovnakým názvom, prípadne pridá celý nový disk. Ďalšie listy budú zbytočné. Ale je to zložitejšie na premyslenie, je to na 2. koľaji. Dám vedieť.
Neviem síce čo chcete označiť, ale skúste nepoužiť xlDown, ale od konca xlUp. A pracujte s určite vyplneným stĺpcom, čo A nieje.
Lomítko "\" na konci - ako som písal minule, bez neho to bola asi prapôvodná vizuálna požiadavka. Neviem.
citovat
\n
RSS nejnovější články