Move/Copy macro doesn't work as aspected

Hi.

Got a code that will save all selected files in a directory chosen by the user.
Often it works great but sometimes it doesn't copy/move all the selected files, just a few (about 5-6) and sometimes the new files are just 1kb and doesn't work like the program only copied the icon.

Anyone knows a diffrent way of writing this code ? A code that doesn't bugg ?


My Code:

Sub MoveFiles()
    MoveOrCopy Selection.Cells, False
End Sub

Sub CopyFiles()
    MoveOrCopy Selection.Cells, True
End Sub

Private Sub MoveOrCopy(r As Range, bCopy As Boolean)
   
   
    Dim cell        As Range
    Dim sDir        As String
    Dim sFile       As String
    Dim nFile       As Long


    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Välj mapp"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1) & "\"
    End With

    For Each cell In Selection.Cells
        If Len(cell.Text) Then
            sFile = Mid(cell.Text, InStrRev(cell.Text, "\") + 1)

            If Len(Dir(cell.Text)) Then
                If bCopy Then
                    FileCopy cell.Text, sDir & sFile
                Else
                    Name cell.Text As sDir & sFile
                End If
                
                nFile = nFile + 1
        
            Else
                MsgBox "Går inte att flytta: " & cell.Text
            End If
        End If
    Next cell
    
    
    MsgBox IIf(bCopy, "Kopierat ", "Flyttat ") & nFile & " fil(er)"

    
End Sub

Hi pero
which line fails?

The only thing I can see if the sfile name or sdir string are wrong in the range
do you have a small sample workbook?

I use this code to copy file(s)

Sub CopyFile()
    Dim fs As Object
    Dim strFile As String
    Dim strNewFile As String
    strFile = "C:\Ptest.xls"
    strNewFile = "C:\Program Files\Ptest.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    fs.CopyFile strFile, strNewFile
    MsgBox "A copy of the specified file was created."
    Set fs = Nothing
End Sub

or you may need to check if

Sub DoesFolderExist()
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    MsgBox fs.FolderExists("C:\Program Files")
End Sub

Sub FileExists()
    Dim fs As Object
    Dim strFile As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    strFile = InputBox("Enter the full name of the file:")
    If fs.FileExists(strFile) Then
        MsgBox strFile & " was found."
    Else
        MsgBox "File does not exist."
    End If
End Sub

I check your code out when I get a chance
See ya

ooOps

Wrong post

Hi Pero,
try this..half finnished code ....

Option Explicit
Sub MoveFiles()
   MoveOrCopy Selection.Cells, False
End Sub
Sub CopyFiles()
    MoveOrCopy Selection.Cells, True
End Sub
Sub MoveOrCopy(r As Range, bCopy As Boolean)
Dim z!, e!, a, u$, sDir$, fs As Object
On Error Resume Next
With Selection.Cells
a = .Cells
z = .Rows.Count
End With
If z = 0 Then
MsgBox "select some cells"
Exit Sub
End If
 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Välj mapp"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1) & "\"
End With
For e = 1 To z
u = a(e, 2) & "\" & a(e, 1) & ".*"
Set fs = CreateObject("scripting.filesystemobject")
         If bCopy = True Then
            fs.Copyfile u, sDir
          Else: fs.Movefile u, sDir
        End If
Set fs = Nothing
Next
 Exit Sub
Errorhandler:
    If Err = "75" Then
        MsgBox ("Åtkomst nekad. Kan bero på att filen är öppen eller att du inte har behörighet till filen.")
    End If
    If Err = "70" Then
        MsgBox ("Du kan inte kopiera en öppen fil. Stäng filen och försök igen.")
        Exit Sub
    End If
End Sub

will have to add these checks

Sub DoesFolderExist()
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    MsgBox fs.FolderExists("C:\Program Files")
End Sub

Sub FileExists()
    Dim fs As Object
    Dim strFile As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    strFile = InputBox("Enter the full name of the file:")
    If fs.FileExists(strFile) Then
        MsgBox strFile & " was found."
    Else
        MsgBox "File does not exist."
    End If
End Sub

this should have it
cant find if the file exist with out the extension

Option Explicit
Sub MoveFiles()
   MoveOrCopy Selection.Cells, False
End Sub
Sub CopyFiles()
    MoveOrCopy Selection.Cells, True
End Sub
Sub MoveOrCopy(r As Range, bCopy As Boolean)
Dim z!, e!, a, u$, sDir$, fs As Object
With Selection.Cells
a = .Cells
z = .Rows.Count
End With
If z = 0 Then
MsgBox "select some cells"
Exit Sub
End If
 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Välj mapp"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1) & "\"
End With
For e = 1 To z
u = a(e, 2) & "\" & a(e, 1) & ".*"
If DoesFolderExist(a(e, 2) & "\") Then
Set fs = CreateObject("scripting.filesystemobject")
         If bCopy = True Then
          On Error GoTo NoFile
            fs.Copyfile u, sDir
          ElseIf bCopy = False Then
            On Error GoTo NoFile
             fs.Movefile u, sDir
          Else:
NoFile:         MsgBox "File dosent exist : " & a(e, 1)
          End If
Set fs = Nothing
Else: MsgBox "Folder dosent exist : " & a(e, 2) & "\"
End If
Next
End Sub
Function DoesFolderExist(strFile) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
   If fs.FolderExists(strFile) Then
          DoesFolderExist = True
    Else
        DoesFolderExist = False
    End If
  End Function

Pero how did the code go???

Bump Bump Bump

Hey!

Have been away for a while. Will test the code now and come back with the results.
Thaks for your time!!

EDIT:
WHen I run the macros I get an error. Error nr 9, "The index is out of the interval"

I got the errormessage in swedish and thne tried to translate it. Its not a quote.

The line markedin VBA is:

u = a(e, 2) & "\" & a(e, 1) & ".*"

How do I fix this ?

Again Thank you !

//

Per

Pero did you select/highlight the files/folders to move or copy?

Pero use..

Sub MoveOrCopy(r As Range, bCopy As Boolean)
Dim z!, e!, a, u, sDir$, fs As Object
With Selection.Cells
a = .Cells
z = .Rows.Count

If z < 2 Then
MsgBox "select some cells"
Exit Sub
End If
End With
 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Välj mapp"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1) & "\"
End With
For e = 1 To z
u = a(e, 2) & "\" & a(e, 1) & "*"
If DoesFolderExist(a(e, 2) & "\") Then
Set fs = CreateObject("scripting.filesystemobject")
         If bCopy = True Then
          On Error GoTo NoFile
            fs.Copyfile u, sDir
          ElseIf bCopy = False Then
            On Error GoTo NoFile
             fs.Movefile u, sDir
          Else:
NoFile:         MsgBox "File dosent exist : " & a(e, 1)
          End If
Set fs = Nothing
Else: MsgBox "Folder dosent exist : " & a(e, 2) & "\"
End If
Next
End Sub

Pero try..

Option Explicit
Sub MoveFiles()
    MoveOrCopy Selection.Cells, False
End Sub
Sub CopyFiles()
    MoveOrCopy Selection.Cells, True
End Sub
Sub MoveOrCopy(r As Range, bCopy As Boolean)
    Dim i!, ii!, e, a$, z$, sDir$, fs As Object
    i = r.Rows.Count
    ii = r.Columns.Count
    If i < 0 Then
        MsgBox "select some cells"
        Exit Sub
        elseIf ii > 1 Then
            MsgBox "selected too many Columns"
            Exit Sub
        End If
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Välj mapp"
            .AllowMultiSelect = False
            If .Show = 0 Then Exit Sub
            sDir = .SelectedItems(1) & "\"
        End With
        For Each e In r
            a = e.Offset(0, 1).Value
            z = FileName(a)
            If DoesFolderExist(z) Then
                If DoesFileExist(a) Then
                    Set fs = CreateObject("scripting.filesystemobject")
                    If bCopy = True Then
                        fs.Copyfile a, sDir
                    Else: bCopy = False
                        fs.Movefile a, sDir
                    End If
                Else: MsgBox "File dosent exist : " & a
                End If
            Else: MsgBox "Folder dosent exist : " & z
            End If
        Next
        Set fs = Nothing
    End Sub
Function DoesFolderExist(strFile$) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strFile) Then
        DoesFolderExist = True
    Else
        DoesFolderExist = False
    End If
End Function
Function DoesFileExist(strFile$) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(strFile) Then
        DoesFileExist = True
    Else
        DoesFileExist = False
    End If
End Function
Function FileName(strFilename$) As String
    Dim intLastSep!
    intLastSep = InStrRev(strFilename, "\")
    FileName = Left(strFilename, intLastSep - 1)
End Function

Comment ; This code will differ from the email as I have to change the if to elseif

no thank you for marking the post solved