Excel VBA基于表中的文件夹名称创建文件夹并移动文件

我在一个名为“Z:\ContactLog\”的文件夹中有大约10000个文件。文件名为“Contact_1.pdf”、“Contact_2.pdf”等。我还有一个访问表，第一列列出了文件名，第二列列出了相关的组名。组名为“Group1”、“Group2”等

我需要帮助来编写VBA代码，以便使用组名作为文件夹名为每个组创建一个子文件夹（例如“Z:\ContactLog\Group1\”），然后根据表中文件名列出的组名将文件移动到文件夹中

---

到目前为止，我的研究已经找到了基于文件名而不是基于表字段条目移动文件的代码。如果有任何关于开始编写VBA的帮助，我将不胜感激。我正在使用Access 2010，但如果需要，我会在Excel中这样做。谢谢。

我希望回答您自己的问题不会被认为是不好的形式，但我有just用完全不同的方法思考并测试了答案

为了实现这个目标，我做了以下几点：

将access表导出到Excel，使A列具有文件名，B列具有所需目标文件夹的名称

在C列中使用公式

=CONCATENATE（“xcopy Z:\ContactLog\”，A1，“.pdf Z:\ContactLog\”，B1，“\/C”）

向下复制所有10000个条目的公式

将列C复制并粘贴到批处理文件中

运行批处理文件

手动删除源文件

---

我在一小部分条目上尝试过这个方法，效果非常好。Xcopy将创建不存在的文件夹。如果出现错误（例如，文件不存在），开关“/C”将允许批处理继续进行。

看起来像是您的集合，但我想我会添加一个访问答案来解决问题

首先备份有问题的整个文件夹，以便在出现问题时恢复。然后在文件信息表中添加一个名为file_MOVED的列，以便将其用作标志

我做过很多类似的事情，遇到过很多问题，比如文件移动、重命名、锁定等（如果在运行中出现错误，在后续运行中尝试移动已移动的文件时，您将遇到更多错误）如果必须还原到原始文件夹，请确保将文件\u MOVED col更新为0或null。下面是一些代码，可以实现您的目标：

在模块中声明：

Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Function OrganizeFiles() As Long
On Error GoTo ErrHandler
Dim rst As New ADODB.Recordset
Dim strFolderFrom As String, strFolderTo As String
Dim strPathFrom As String, strPathTo As String

rst.CursorLocation = adUseClient
rst.CursorType = adOpenForwardOnly
rst.LockType = adLockOptimistic

rst.Open "SELECT * FROM [YourTableName] WHERE nz(FILE_MOVED,0) = 0 ", CurrentProject.Connection

strFolderFrom = "Z:\ContactLog\" 'the main folder will always be the same
Do Until rst.EOF

'destination folder
strFolderTo = strFolderFrom & rst.Fields("[YourGroupCol]") & "\" 'destination folder can change

'make sure the destination folder is there; if not, then create it
If Dir(strFolderTo, vbDirectory) = "" Then MkDir strFolderTo

'get the source file path
strPathFrom = strBaseFolder & rst.Fields("[YourFileNameCol]")

'get the destination file path
strPathTo = strFolderTo & rst.Fields("[YourFileNameCol]")

Call MoveFile(strPathFrom, strPathTo)

'at this point the file should have been moved, so update the flag
rst.Fields("FILE_MOVED") = 1

rst.MoveNext
Loop

rst.Close

ErrHandler:
Set rst = Nothing
If err.Number <> 0 Then
MsgBox err.Description, vbExclamation, "Error " & err.Number
End If
End Function

将其粘贴到模块中：

Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Function OrganizeFiles() As Long
On Error GoTo ErrHandler
Dim rst As New ADODB.Recordset
Dim strFolderFrom As String, strFolderTo As String
Dim strPathFrom As String, strPathTo As String

rst.CursorLocation = adUseClient
rst.CursorType = adOpenForwardOnly
rst.LockType = adLockOptimistic

rst.Open "SELECT * FROM [YourTableName] WHERE nz(FILE_MOVED,0) = 0 ", CurrentProject.Connection

strFolderFrom = "Z:\ContactLog\" 'the main folder will always be the same
Do Until rst.EOF

'destination folder
strFolderTo = strFolderFrom & rst.Fields("[YourGroupCol]") & "\" 'destination folder can change

'make sure the destination folder is there; if not, then create it
If Dir(strFolderTo, vbDirectory) = "" Then MkDir strFolderTo

'get the source file path
strPathFrom = strBaseFolder & rst.Fields("[YourFileNameCol]")

'get the destination file path
strPathTo = strFolderTo & rst.Fields("[YourFileNameCol]")

Call MoveFile(strPathFrom, strPathTo)

'at this point the file should have been moved, so update the flag
rst.Fields("FILE_MOVED") = 1

rst.MoveNext
Loop

rst.Close

ErrHandler:
Set rst = Nothing
If err.Number <> 0 Then
MsgBox err.Description, vbExclamation, "Error " & err.Number
End If
End Function

函数OrganizeFiles（）的长度
关于错误转到错误处理程序
将rst设置为新ADODB.Recordset
将strFolderFrom设置为字符串，将strFolderTo设置为字符串
将strPathFrom设置为字符串，strPathTo设置为字符串
rst.CursorLocation=adUseClient
rst.CursorType=adOpenForwardOnly
rst.LockType=ADLOCKTYPE
rst.Open“从[YourTableName]中选择*，其中nz（文件0）=0”，CurrentProject.Connection
strFolderFrom=“Z:\ContactLog\”主文件夹将始终保持不变
直到rst.EOF为止
'目标文件夹
strFolderTo=strFolderFrom&rst.Fields（“[YourGroupCol]”）和“\”目标文件夹可以更改
'确保目标文件夹在那里；如果没有，则创建它
如果Dir（strFolderTo，vbDirectory）=“”，则MkDir strFolderTo
'获取源文件路径
strPathFrom=strBaseFolder&rst.Fields（“[YourFileNameCol]”）
'获取目标文件路径
strPathTo=strFolderTo&rst.Fields（“[YourFileNameCol]”）
调用MoveFile（strPathFrom、strPathTo）
'此时文件应该已移动，因此请更新标志
rst.Fields（“文件已移动”）=1
rst.MoveNext
环
rst.关闭
错误处理程序：
设置rst=无
如果错误号为0，则
MsgBox错误描述、VBEQUOTE、“错误”和错误编号
如果结束
端函数

---

此任务和“我的代码”非常基本，但在处理多个源文件夹和目标文件夹时，或者在移动它们的同时更改文件名时，这类事情可能会变得复杂。

您拥有的文件夹名。因此，您似乎只需要一个子文件夹来创建这些文件夹。因为您说过，您已经编写了将文件向后移动的代码erwards它真的可以归结为这样一个sub。我相信你正在寻找的sub可以在这里找到：嗨Ralph，谢谢你提供的信息。这将帮助我创建文件夹部分。我找到的唯一移动文件的VBA代码使用文件名来确定目标文件夹的位置。我正在努力找到将移动的VBA代码该文件基于数据库字段。感谢您的实际操作，我感谢您的帮助。作为同一项目的一部分，我还有许多其他文件移动要做，因此这将非常有用。