Как вставить счетчик счетчик #excelvba

Question

У меня есть измененный макрос из интернета.Этот макрос копирует / перемещает файлы из одной папки в другую на основе списка в 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) & "\"
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
        Kill xSPathStr & xVal 'Delete files from SOURCE
    End If
Next
  Msgbox '(This prompt USER for count of successful copied files)
End Sub

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

Рей

Answer 1

Хитрость заключается в том, чтобы добавить 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) & "\"
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
        xCount = xCount + 1
        Kill xSPathStr & xVal
    End If
Next

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

End Sub