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

Nguyen Anh Dung

Board Regular
Joined
Feb 28, 2020
Messages
180
Office Version
  1. 2016
Platform
  1. Windows
I have folder include file *.excel and *.csv. I want copy to subfolder have name same file.
folder: C:\Users\dungna\Desktop\Text_excel
1622540633758.png


folder copy to: C:\Users\dungna\Desktop\test\Image_SoNha
1622540660498.png



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"
Code:
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
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
How does this work for you?
VBA Code:
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
 
Upvote 0
How does this work for you?
VBA Code:
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!!!
 
Upvote 0

Forum statistics

Threads
1,224,818
Messages
6,181,150
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top