Question

我在文件夹中有多个图像，如果文件名有特定字，则需要将其移动到相应的文件夹。

以下代码适用于csv文件但不适用于.jpg

1.如何转换适用于任何文件类型的代码。

而不是在宏代码中添加文件夹名称（要创建并将各个文件移动到其中）。采取

来自A列的文件名，来自B列的文件路径，.. if文件夹没有创建它并将相应的文件移动到该文件夹。

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： - 如果A列中的文件名是＆＃34; Download-Aability-pic-quote.jpg＆＃34;和Pic 2是＆＃34; Download-Ability-newton-quotes.jpg＆＃34;然后创建文件夹＆＃34;能力＆＃34;并将两个文件移动到该文件夹。 B列包含要移动的图像的路径，例如＆＃34; E：\ Work \ DPforMe \ Moving files \ Macro test \ Ability＆＃34;。和其他图像移动到缺席。注意：从列B中的路径获取要创建的文件夹名称。将保存图像的最后一个文件夹名称是要创建的文件夹。

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

应该这样做！

Answer 2

我从其他来源获得解决方案：

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

注意： Excel工作表名称应为＆＃34; 来源＆＃34;

工作表应该有标题＆＃34; FileName DestinaionPath Moved ＆＃34;

在代码中 - Const FolderA =＆＃34; Z：\ Folder A **＆＃34;是位于文件的**源文件夹。

感谢 Stuart McCormack （解决方案提供商）以及所有试图帮助解决此问题的人。

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

2 个答案: