Sub CopyFiles()
    Dim fso As Object, i As Integer, lastColumn As Integer, copyToPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    Let lastColumn = Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Column
    If lastColumn = 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .ButtonName = "Выбрать папку"
        .Title = "Выбор папки"
        If .Show = -1 Then
            copyToPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    If Right(copyToPath, 1) <> "\" Then copyToPath = copyToPath & "\"
    If Not fso.FolderExists(copyToPath & Cells(ActiveCell.Row, 1).Text) Then
        fso.CreateFolder (copyToPath & Cells(ActiveCell.Row, 1).Text)
    End If
    copyToPath = copyToPath & Cells(ActiveCell.Row, 1).Text & "\"
    For i = 2 To lastColumn
        If fso.FileExists(Cells(ActiveCell.Row, i).Text) Then
            fso.CopyFile Cells(ActiveCell.Row, i).Text, copyToPath
        End If
    Next i
    Set fso = Nothing
End Sub