Блог

У меня есть модифицированный макрос из Интернета. Этот макрос копирует / перемещает файлы из одной папки в другую на основе списка в Excel, а не всех файлов в исходной папке. Мои цели — подсказать пользователю, сколько файлов было успешно скопировано.

Вот код:

 Private Sub CommandButton1_Click()

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
Dim xCount As Long

ActiveSheet.Range("a4:a1000").Select 'List of Files to copy from source to destination folder

On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "Files Selected", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Please select the Source folder:"

If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) amp; ""
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Please select the Destination folder:"

If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) amp; ""
For Each xCell In xRg
    xVal = xCell.Value
    If TypeName(xVal) = "String" And xVal <> "" Then
        FileCopy xSPathStr amp; xVal, xDPathStr amp; xVal
        Kill xSPathStr amp; xVal 'Delete files from SOURCE
    End If
Next
  Msgbox '(This prompt USER for count of successful copied files)
End Sub
  

Спасибо за помощь

Рей

Хитрость заключается в том, чтобы добавить 1 к переменной, а затем отобразить эту переменную, скажем, в окне сообщения

 Private Sub CommandButton1_Click()

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
Dim xCount As Long

ActiveSheet.Range("a4:a5000").Select 'Select active cells

On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "Files Selected", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Please select the Source folder:"

If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) amp; ""
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Please select the Destination folder:"

If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) amp; ""
For Each xCell In xRg
    xVal = xCell.Value
    If TypeName(xVal) = "String" And xVal <> "" Then
        FileCopy xSPathStr amp; xVal, xDPathStr amp; xVal
        xCount = xCount   1
        Kill xSPathStr amp; xVal
    End If
Next

MsgBox "Task finished. " amp; xCount amp; " files were succesfully copied.", vbInformation, "Finished"

End Sub