Úprava kódu Vyřešeno

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

Moderátor: Mods_senior

luko02420
Level 1.5
Level 1.5
Příspěvky: 140
Registrován: únor 12
Pohlaví: Nespecifikováno

Ú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
Level 2
Příspěvky: 189
Registrován: červen 13
Pohlaví: Muž

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 1.5
Level 1.5
Příspěvky: 140
Registrován: únor 12
Pohlaví: Nespecifikováno

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
Level 2
Příspěvky: 189
Registrován: červen 13
Pohlaví: Muž

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 1.5
Level 1.5
Příspěvky: 140
Registrován: únor 12
Pohlaví: Nespecifikováno

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
  • Úprava kódu pro odeslání emailu.
    od luko02420 » 01 zář 2018 20:10 » v Kancelářské balíky
    6
    758
    od luko02420
    04 zář 2018 20:14
  • Úprava kodu pro odeslání pdf.
    od luko02420 » 05 zář 2018 07:48 » v Kancelářské balíky
    6
    567
    od luko02420
    05 zář 2018 11:01
  • Oprava kódu chyby 0xc0000020
    od DeXx™ » 16 lis 2018 15:35 » v Windows 10, 8, 7, Vista, XP…
    6
    621
    od DeXx™
    20 lis 2018 17:17
  • Aktivace software pomoci kodu orig software
    od sramis1375 » 08 čer 2018 16:15 » v Multimédia (filmy, hudba, CDs/DVDs)
    1
    1217
    od mmmartin
    08 čer 2018 16:57
  • Úprava videí
    od HelFix » 16 bře 2019 14:25 » v Poptávka po práci
    9
    1403
    od HelFix
    26 bře 2019 19:06

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

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot] a 2 hosti