help edit code copy file for both *.excel and *.csv

[Nguyen Anh Dung]

I have folder include file *.excel and *.csv. I want copy to subfolder have name same file.
folder: C:\Users\dungna\Desktop\Text_excel

folder copy to: C:\Users\dungna\Desktop\test\Image_SoNha

i have code only copy csv. help me edit code copy for both.
In this case copy xls i have condition: If Right(fName, 7) Like "_0#.xls"

Option Explicit
Sub MoveFilescsv1()
Dim fName As String, fromPath As String, toPath As String
Dim toSubPath As String, cnt As Long
Dim toSubPath1 As String, cnt1 As Long
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fromPath = Application.InputBox("Nhap duong dan nguon: ")
toPath = Application.InputBox("Nhap duong dan dich: ")

fName = Dir(fromPath & "*.csv")
Do While Len(fName) > 10

    If Right(fName, 11) Like "_0#_img.csv" Then
    cnt = 0
    toSubPath = toPath & Left(fName, Len(fName) - 8) & "\"
  
    If fso.FileExists(toSubPath & fName) Then fso.DeleteFile toSubPath & fName, True
    fso.MoveFile fromPath & fName, toSubPath & fName
     
    End If
   
    fName = Dir
  
Loop
cnt = cnt + 1
MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!"
End Sub

best regards,
Nguyen Anh Dung

 

[shknbk2]

How does this work for you?

Option Explicit

Sub MoveFilescsv1()
    Dim fName As String, fromPath As String, toPath As String
    Dim toSubPath As String, cnt As Long
    Dim toSubPath1 As String, cnt1 As Long
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim FilePattern(1) As String, fCount As Integer
    FilePattern(0) = "_0#_img.csv"
    FilePattern(1) = "_0#.xls"
    
    On Error Resume Next
    fromPath = Application.InputBox("Nhap duong dan nguon: ")
    toPath = Application.InputBox("Nhap duong dan dich: ")
      
    For fCount = LBound(FilePattern) To UBound(FilePattern)
        fName = Dir(fromPath & "*." & Right(FilePattern(fCount), Len(FilePattern(fCount)) - InStrRev(FilePattern(fCount), ".")))
        Do While Len(fName) > 10
            If Right(fName, Len(FilePattern(fCount))) Like FilePattern(fCount) Then
            cnt = 0
            toSubPath = toPath & Left(fName, Len(fName) - 8) & "\"
          
            If fso.FileExists(toSubPath & fName) Then fso.DeleteFile toSubPath & fName, True
            fso.MoveFile fromPath & fName, toSubPath & fName
             
            End If
           
            fName = Dir
          
        Loop
    Next
    cnt = cnt + 1
    MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!"
End Sub

 

[Nguyen Anh Dung]

How does this work for you?

Option Explicit

Sub MoveFilescsv1()
    Dim fName As String, fromPath As String, toPath As String
    Dim toSubPath As String, cnt As Long
    Dim toSubPath1 As String, cnt1 As Long
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    Dim FilePattern(1) As String, fCount As Integer
    FilePattern(0) = "_0#_img.csv"
    FilePattern(1) = "_0#.xls"
   
    On Error Resume Next
    fromPath = Application.InputBox("Nhap duong dan nguon: ")
    toPath = Application.InputBox("Nhap duong dan dich: ")
     
    For fCount = LBound(FilePattern) To UBound(FilePattern)
        fName = Dir(fromPath & "*." & Right(FilePattern(fCount), Len(FilePattern(fCount)) - InStrRev(FilePattern(fCount), ".")))
        Do While Len(fName) > 10
            If Right(fName, Len(FilePattern(fCount))) Like FilePattern(fCount) Then
            cnt = 0
            toSubPath = toPath & Left(fName, Len(fName) - 8) & "\"
         
            If fso.FileExists(toSubPath & fName) Then fso.DeleteFile toSubPath & fName, True
            fso.MoveFile fromPath & fName, toSubPath & fName
            
            End If
          
            fName = Dir
         
        Loop
    Next
    cnt = cnt + 1
    MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!"
End Sub

thanks you so much!!!