Excel宏将多个jpg文件移动到多个文件夹

Question

i have multiple images in folder which need to be moved to respective folders if the file name has a specific word.

Following code works fine for csv files but not working for .jpg

1.How can i convert this code that should work for any file type.

2. Instead of adding the folder name(to be created and moved respective files into it) in the macro code. take

File name from Column A, File path from Column B, ..if folder not there create it and move respective file to the folder.

Sub Movefiles()
Const SourceFolder As String = "E:\Work\DPforMe\Moving files\Macro test\"
Dim oFSO
Dim oFolder As Object
Dim oFile As Object
Dim NewFolder As String

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFSO.GetFolder(SourceFolder)

For Each oFile In oFolder.Files

If oFile.Type Like "*Comma Separated Values*" Then
Select Case True
Case oFile Like "*ability*"
NewFolder = "ability\"
Case oFile Like "*absence*"
NewFolder = "absence\"
'etc
End Select
Name oFile.Path As SourceFolder & NewFolder & oFile.Name
End If
Next oFile

Set oFolder = Nothing
Set oFSO = Nothing

End Sub 

Ex:- If file name in Column A is "Download-Aability-pic-quote.jpg" and Pic 2 is "Download-Ability-newton-quotes.jpg" then create folder "ability" and move both files to the folder. Column B contains the path of the image to be moved , say "E:\\Work\\DPforMe\\Moving files\\Macro test\\Ability". and other image moved to Absence. Note:Take the folder name to be created from path in column B. The last folder name where image will be saved is the folder to be created.

COLUMN A:

download-ability-whatsapp-dp-status-bierce-ambrose-image-pic-quotes-5.jpg
download-ability-whatsapp-dp-status-bonaparte-napoleon-image-pic-quotes-1.jpg
download-ability-whatsapp-dp-status-bonaparte-napoleon-image-pic-quotes-2.jpg
download-ability-whatsapp-dp-status-brilliant-ashleigh-image-pic-quotes-1.jpg
download-absence-whatsapp-dp-status-de-la-bruyre-jean-image-pic-quotes-1.jpg
download-absence-whatsapp-dp-status-franklin-benjamin-image-pic-quotes-3.jpg

COLUMNB

E:\Work\DPforMe\Creating Quotes\Macro test\Ability
E:\Work\DPforMe\Creating Quotes\Macro test\Ability
E:\Work\DPforMe\Creating Quotes\Macro test\Ability
E:\Work\DPforMe\Creating Quotes\Macro test\Ability
E:\Work\DPforMe\Creating Quotes\Macro test\Absence
E:\Work\DPforMe\Creating Quotes\Macro test\Absence

Answer 1

Sub Movefiles()

Const SourceFolder As String = "E:\Work\DPforMe\Moving files\Macro test"

Dim oFSO
Dim oFolder As Object
Dim oFile As Object
Dim DestinationFolder As String
Dim objFolder

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(SourceFolder)

For Each oFile In oFolder.Files

        DestinationFolder = "E:\Work\DPforMe\Moving files\Macro test" & "\" & oFile.Type '& "\"

        'Check whether folder exists
        If oFSO.FolderExists(DestinationFolder) Then
            Set objFolder = oFSO.GetFolder(DestinationFolder)
        Else
           Set objFolder = oFSO.CreateFolder(DestinationFolder)
        End If

        'once folder created, move the file to that folder
        If oFSO.FolderExists(DestinationFolder) Then
            SourceFileLocation = (SourceFolder & "\" & oFile.Name)
            Destinationfilelocation = (DestinationFolder & "\" & oFile.Name)
            oFSO.MoveFile SourceFileLocation, Destinationfilelocation
        End If

Next oFile

Set oFolder = Nothing
Set oFSO = Nothing

End Sub

This ought to do it!

Answer 2

i got solution from another source:

https://www.quora.com/How-do-I-move-multiple-files-to-multiple-folders-at-once-using-VBA-macro

Public Sub MoveFiles()
' Fang thru source sheet.
' Move any FolderA files (columnA) to dirs in ColumnB
'  if they are not already flagged as having been moved in ColumnC.
' This code would work better with a function that ensures the target
'  directory actually exists.  Just sayin'.
' smac 5 May 2017.  42 years since first job in IT TODAY!!

Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "Z:\Folder A\"    ' NOTE trailing backslash
Const srcSheet = "Source"

Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long              ' row number
Dim fName As String
Dim fPath As String

  ' get ready

  Set xlW = ActiveWorkbook
  Set xlS = xlW.Sheets(srcSheet)

  RN = 2
  fName = Trim(xlS.Cells(RN, colA).Text)

  ' We'll run thru ColA until we hit a blank

  On Error Resume Next  ' expect problems if no target Dir

  While fName <> ""

    ' if it hasn't aready been moved

    If Trim(xlS.Cells(RN, colC).Text) = "" Then

      ' got one.
      ' Get the path.  Ensure trailing backslash

      fPath = Trim(xlS.Cells(RN, colB).Text)

      If Right(fPath, 1) <> "\" Then fPath = fPath & "\"

      ' if the target already exists, nuke it.

      If Dir(fPath & fName) <> "" Then Kill fPath & fName

      ' move it

      FileCopy FolderA & fName, fPath & fName
      DoEvents

      ' report it

      If Err.Number <> 0 Then

        xlS.Cells(RN, colC).Value = "Failed: Check target Dir"

        Err.Clear

      Else

        xlS.Cells(RN, colC).Value = Now()

      End If
    End If

    ' ready for next one

    RN = RN + 1
    fName = Trim(xlS.Cells(RN, colA).Text)

  Wend

  MsgBox "Done it!!"

End Sub

Note: The excel sheet name should be " Source "

Sheet should have headers" FileName DestinaionPath Moved "

In code-Const FolderA = " Z:\\Folder A**" is the **source folder of the files located.

Thanks to Stuart McCormack (the solution provider), and to all who tried to help to resolve the issue.