Úprava kódu Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 218
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Úprava kódu

Příspěvekod luko02420 » 04 dub 2019 11:33

Dobrý den, potřebuji poradit jak upravit následující kód na kopirování aby me to automaticky ukladalo do určených složek.
Ted to musim delat rucne, coz neni ono.
Dekuji vsem za pomoc.

Kód: Vybrat vše

Sub copyfiles()
'Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = ActiveSheet.Range("A2:A5")  'Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 1)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
        End If
    Next
End Sub

Reklama
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 386
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Úprava kódu

Příspěvekod elninoslov » 04 dub 2019 11:50

??? Takže nechcete vyberať v tých dvoch dialógových oknách Source zložku ani Destination zložku ? Tak tie premenné zadefinujte natrvalo a v kóde im priradte cesty.

Kód: Vybrat vše

xSPathStr = "C:\Fero Mrkva\Origo\"
xDPathStr = "C:\Jano Lúčny\Kópie\"

Inak Vám nerozumiem, o čo teda ide. Čo presne znamená "automaticky ukladalo do určených složek". Uveďte konkrétne príklady.

luko02420
Level 2
Level 2
Příspěvky: 218
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Úprava kódu

Příspěvekod luko02420 » 04 dub 2019 12:45

Dobrý den, šlo mi přesně o to, jak jste to pochopil. Nechci tam ty dialogove okna. Pokouším se do kodu pridat ty cesty natrvalo ale zatim se mi to nedarí.

Prosim kde přesně nastavit cestu nemuzu to rozchodit. Dekuji

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 386
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Úprava kódu

Příspěvekod elninoslov » 04 dub 2019 14:58

Kód: Vybrat vše

Sub copyfiles()
    Dim xCell As Range
    Dim xVal As String
   
    Const xSPathStr = "z:\Kopírovanie označených súborov\Origo\"
    Const xDPathStr = "z:\Kopírovanie označených súborov\Kópie\"
   
    On Error Resume Next
    For Each xCell In ActiveSheet.Range("A2:A5")
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
        End If
    Next xCell
End Sub

luko02420
Level 2
Level 2
Příspěvky: 218
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Úprava kódu  Vyřešeno

Příspěvekod luko02420 » 04 dub 2019 15:31

To je presne ono, rikam to porad, ze mate zlaty ruce.
Dekuji


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Prosím o úpravu kódu. Děkuji *
    od junis » 09 črc 2024 18:05 » v Kancelářské balíky
    4
    4494
    od junis Zobrazit poslední příspěvek
    22 črc 2024 17:54
  • Uprava vzorce
    od junis » 27 črc 2024 15:43 » v Kancelářské balíky
    6
    5347
    od junis Zobrazit poslední příspěvek
    02 srp 2024 18:02
  • Úprava pc pro Kingdome Come Deliverance 2
    od barryk10cz » 07 led 2025 17:00 » v Rady s výběrem hw a sestavením PC
    13
    3834
    od Hangli Zobrazit poslední příspěvek
    09 led 2025 22:42
  • Raspberry - M2 disk - uprava a zaloha oddilu Příloha(y)
    od L.L » 18 srp 2024 10:32 » v Problémy s hardwarem
    3
    3787
    od L.L Zobrazit poslední příspěvek
    19 srp 2024 14:39
  • bitmapová grafika - úprava fotografií, retuše, filtry.
    od zuzana3 » 10 kvě 2025 11:32 » v Design a grafické editory
    2
    5251
    od zuzana3 Zobrazit poslední příspěvek
    10 kvě 2025 17:31

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 5 hostů