Úprava kódu

[luko02420]

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

[elninoslov]

??? 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]

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

[elninoslov]

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]

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