Question

我在一个名为＆＃34; Z：\ ContactLog \＆＃34;的文件夹中有大约10,000个文件。这些文件命名为＆＃34; Contact_1.pdf＆＃34;，＆＃34; Contact_2.pdf＆＃34;我还有一个Access表，其中第一列中列出了文件名，第二列中列出了相关的组名。组名是＆＃34; Group1＆＃34;，Group2＆＃34;等

我需要帮助来编写VBA代码，使用组名作为文件夹名称为每个组创建子文件夹（例如＆＃34; Z：\ ContactLog \ Group1 \＆＃34;）然后移动根据表中文件名列出的组名称将文件放入文件夹中。

到目前为止，我的研究已找到基于文件名移动文件的代码，但不是基于表字段条目。任何开始编写VBA的帮助都将不胜感激。我正在使用Access 2010，但如果需要，将在Excel中执行此操作。谢谢。

Answer 1

我希望回答你自己的问题不被认为是不好的形式，但我刚刚想到并用一种完全不同的方法测试了答案。

为了达到目标，我做了以下工作：

将访问表导出到Excel，因此A列具有文件名，B列具有所需目标文件夹的名称。
在C栏中使用公式......

=CONCATENATE("xcopy Z:\ContactLog\",A1,".pdf Z:\ContactLog\",B1,"\ /C")

将所有10,000个条目的公式向下复制
将C列复制并粘贴到批处理文件中
运行批处理文件
手动删除源文件

我在条目的一小部分样本上尝试了这个，它完美无缺。 Xcopy将创建不存在的文件夹。如果出现错误，交换机“/ C”将允许批处理继续（例如，如果文件不存在）。

Answer 2

看起来像你的设置，但我想我会为它添加一个Access答案。

首先备份相关的整个文件夹，这样您就可以恢复出错的地方。接下来在名为FILE_MOVED的文件信息表中添加一列，以便将其用作标志。

我已经做了很多这样的事情并且遇到了很多问题，例如文件被移动，重命名，锁定等等。（如果在运行中出现错误，你就会结束尝试移动已经移动的文件后续运行时出现更多错误。）如果必须恢复到原始文件夹，请务必将FILE_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

这个任务和我的代码非常基本，但是当处理多个源文件夹和目标文件夹或更改文件名以及移动文件名时，这种事情会变得复杂。

VBA根据表

2 个答案: