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

debugcn 发表于 Dev

内存

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

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

1.我怎样才能转换这个适用于任何文件类型的代码。

而不是在宏代码中添加文件夹名称（要创建并将相应的文件移动到其中）。拿

来自 A 列的文件名，来自 B 列的文件路径，.. 如果文件夹不在那里，则创建它并将相应的文件移动到该文件夹。

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

例如：- 如果 A 列中的文件名是“Download-Aability-pic-quote.jpg”，而图片 2 是“Download-Ability-newton-quotes.jpg”，则创建文件夹“能力”并将两个文件移动到该文件夹中。B 列包含要移动的图像的路径，例如“E:\Work\DPforMe\Moving files\Macro test\Ability”。和其他图像移动到缺席。注：B列路径取要创建的文件夹名。最后保存图片的文件夹名就是要创建的文件夹。

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

列

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

内存

我从另一个来源得到了解决方案：

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表格名称应为“ Source ”

工作表应该有标题“ FileName DestinaionPath Moved ”

在代码中，Const FolderA = " Z:\Folder A**" 是文件所在的 ** 源文件夹。

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。