MS Excel

Ahojte som tu nový potreboval by som pomôcť. Robím si zošit na zautomatizovanie práce a zasekol som sa.
Konkrétne mi robí problém makro. Rozdelil som si to na časti a chcel by som aby to fungovalo takto:
Je zošit a dva priečinky priečinok songy v ktorom sú pesničky a priečinok ffff ktorý je prázdny.
Makro by malo:
1.Skopírovať názvy pesničiek v priečinku songy do stlpca C. (to mám vyriešené)
2.Skopírovať pesničky v priečinku songy a prekopírovať ich do priečinku ffff (to mám vyriešené)
3.Premenovať pesničky v priečinku ffff tak aby sa zhodovali so stĺpcom B (to sa mi nedarí)

Zaslat odpověď >

Sperhak(15.2.2021 20:18)#049865

Zabudol som súbor.

Příloha: zip

49865_tets.zip (36kB, staženo 14x)

citovat

Bambulka(16.2.2021 6:03)#049867

Zabudol si hlavne pekné slová.citovat

Sperhak(16.2.2021 7:56)#049869

Ahojte sa mi zdá dosť pekné, ale nabudúce skúsim nájsť peknejšie.citovat

elninoslov(16.2.2021 10:29)#049873

Ohľadom premenovania skúste pozrieť, ako som to robil tu.
EDIT:
Pr.
Sub kopirovanie_a_premenovanie()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim aNewNames()
Dim aOldNames()
Dim CountFiles As Long
Dim sPath As String
Dim sSourcePath As String
Dim sTargetPath As String

Const SOURCE_SUBPATH = "songy"
Const TARGET_SUBPATH = "fffffff"

sPath = ThisWorkbook.Path & "\"
sSourcePath = sPath & SOURCE_SUBPATH & "\"
sTargetPath = sPath & TARGET_SUBPATH & "\"

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sSourcePath)
CountFiles = oFolder.Files.Count

With ThisWorkbook.Worksheets("Hárok1")
Select Case CountFiles
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: Exit Sub
Case 1: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames(1, 1) = .Cells(3, 2).Value
Case Else: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames = .Cells(3, 2).Resize(CountFiles).Value
End Select
aOldNames = aNewNames

On Error Resume Next
For Each oFile In oFolder.Files
i = i + 1
aOldNames(i, 1) = oFile.Name
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR": Err.Clear
Next oFile
On Error GoTo 0

.Cells(3, 3).Resize(CountFiles).Value = aOldNames
End With

Set oFolder = Nothing: Set oFSO = Nothing
End Sub

Příloha: zip

49873_readme.zip (24kB, staženo 10x)

citovat

Sperhak(16.2.2021 16:20)#049880

Vau je to dokonalé ešte aj msgbox ste tam dali. Ďakujem Vám.citovat

elninoslov(16.2.2021 18:19)#049881

Dokonalé určo nie. Teraz som na to pozrel, a hneď vidím jednu vec na ktorú som myslel, ale zabudol ju tam dopísať:
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR": Err.Clear
má byť
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR " & aOldNames(i, 1): Err.Clear
aby tam napísalo aj názov súboru, pri ktorom nastala chyba.

ďalej v tomto riadku
Case Else: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames = .Cells(3, 2).Resize(CountFiles).Value
je ten ReDim zbytočný
Case Else: aNewNames = .Cells(3, 2).Resize(CountFiles).Value

no a programátorsky čisto by malo byť, že ak už máme vytvorené objekty, a vyskakujeme z procedúry, mali by sme objekty zrušiť. Teda pred tento riadok
Set oFolder = Nothing: Set oFSO = Nothing
si pridáme KONIEC:
KONIEC:
Set oFolder = Nothing: Set oFSO = Nothing
a následne budeme vyskakovať z procedúry nie takto
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: Exit Sub
ale takto
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: GoTo KONIEC
a to som ešte zabudol prihodiť na konci objekt súboru
Set oFolder = Nothing: Set oFSO = Nothing
-->
Set oFolder = Nothing: Set oFSO = Nothing: Set oFile = Nothing
Vždy je čo zlepšovať...citovat

Sperhak(16.2.2021 19:08)#049882

Skúsim to prepísať a dám vedieť. Tá chyba čo spomínaťe môže nastane kedy za akých okolností.citovat

elninoslov(16.2.2021 19:34)#049883

Ako píšem, všetko sa dá vylepšovať. Tak napr.
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
tretí parameter True určuje, že existujúci súbor v cieli bude prepísaný. Chyba nastane, napr. ak ten súbor, ktorý sa má prepísať, bude otvorený v prehrávači a hrať. Alebo ak neexistuje cieľový adresár, lebo test na existenciu nerobíme. Alebo to budete ukladať na kľúč, ktorý tam nebude či ho počas kopírovania vytiahnete. Alebo nový názov bude obsahovať nedovolené znaky ... Možností sú mraky.

Úprava by mohla byť napr. takáto:
Sub kopirovanie_a_premenovanie()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim aNewNames()
Dim aOldNames()
Dim CountFiles As Long
Dim sPath As String
Dim sSourcePath As String
Dim sTargetPath As String

Const SOURCE_SUBPATH = "songy"
Const TARGET_SUBPATH = "fffffff"

sPath = ThisWorkbook.Path & "\"
sSourcePath = sPath & SOURCE_SUBPATH & "\"
sTargetPath = sPath & TARGET_SUBPATH & "\"

Set oFSO = CreateObject("Scripting.FileSystemObject")

If Len(Dir(sSourcePath, vbDirectory)) = 0 Then MsgBox "Zdrojová zložka neexistuje." & vbNewLine & sSourcePath: GoTo KONIEC
If Len(Dir(sTargetPath, vbDirectory)) = 0 Then
If MsgBox("Cieľová zložka neexistuje. Chcete ju vytvoriť ?" & vbNewLine & sTargetPath, vbQuestion + vbYesNo) = vbYes Then
If Not CreateDirStruct(oFSO, sTargetPath) Then MsgBox "Cieľovú zložku nie je možné vytvoriť." & vbNewLine & sTargetPath, vbCritical: GoTo KONIEC
Else
GoTo KONIEC
End If
End If

Set oFolder = oFSO.GetFolder(sSourcePath)
CountFiles = oFolder.Files.Count

With ThisWorkbook.Worksheets("Hárok1")
Select Case CountFiles
Case 0: MsgBox "Žiadne súbory v zložke" & vbNewLine & sSourcePath: GoTo KONIEC
Case 1: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames(1, 1) = .Cells(3, 2).Value
Case Else: aNewNames = .Cells(3, 2).Resize(CountFiles).Value
End Select
aOldNames = aNewNames

On Error Resume Next
For Each oFile In oFolder.Files
i = i + 1
Application.StatusBar = i & " / " & CountFiles
aOldNames(i, 1) = oFile.Name
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR " & aOldNames(i, 1): Err.Clear
Next oFile
On Error GoTo 0

.Cells(3, 3).Resize(CountFiles).Value = aOldNames
End With

Application.StatusBar = False
KONIEC:
Set oFolder = Nothing: Set oFSO = Nothing: Set oFile = Nothing
End Sub

Function CreateDirStruct(ByRef oFSO As Object, ByVal sPath As String) As Boolean
Dim aP() As String, aD() As String, i As Byte

sPath = sPath & IIf(Right$(sPath, 1) = "\", "", "\")
aP = Split(sPath, ":\")
aD = Split(aP(1), "\")

sPath = aP(0) & ":"
On Error GoTo END_CREATE
For i = 0 To UBound(aD) - 1
sPath = sPath & "\" & aD(i)
If Len(Dir(sPath, vbDirectory)) = 0 Then oFSO.CreateFolder sPath
Next i
END_CREATE:
CreateDirStruct = Err.Number = 0
End Function
Vyskúšajte, lebo všetko som netestoval, len napísal.

Příloha: zip

49883_readme.zip (27kB, staženo 11x)

citovat

Sperhak(16.2.2021 21:38)#049884

Úpravy som spravil a fungujú. Čo si poslal teraz to asi nebude dobré.Ja to budem kopírovať do takého zariadenia čo sa správa ako usb a tam sa nebudú vytvárať priečinky. Mal som to len takto pracovne v priečinku, lebo to zariadenie má pomalý zápis. Mal som to napísať skôr prepáč.
Ale všimol som si že si tam dal progress bar tak tú časť kódu som využil a hladal som si niečo o tom a až bude čas skúsim tam nejak dostať niečo takéto https://www.excel-easy.com/vba/examples/progress-indicator.html
Načo je dobré vyprádznovať tie premenné týmto príkazom
Set oFolder = Nothing:
Veď pri znovu spustení makra by sa tam uložili nové a fungovalo by to aj bez toho. či sa mýlim?citovat

elninoslov(17.2.2021 0:22)#049888

Ak sú nejaké premenné definované ako objekty, je programátorsky "čisté" ich zrušiť. VBA si takéto obyčajné objekty zruší samozrejme sama po skončení procedúry. Ale pre začiatočníka, je vhodne sa naučiť objekty vždy rušiť. Ono totiž objekt nemusí byť len FSO, ale aj niečo podstatne väčšie a zložitejšie, napr. taká aplikácia. Čo ak bude objektom skrytá inštancia Excelu, Outlooku, ... Tá zostane visieť na systémových prostriedkoch aj po zatvorení Excelu. Aplikácie sa ešte navyše musia najskôr zatvoriť. Krízovo sa zrovna aplikácie sa dajú zrušiť potom v Správcovi úloh, ale iný objekt nemusí.citovat

Téma: Kopirovanie a premenovanie suborov

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje