本文于2023年6月20日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
☆本期内容概要☆
按数字序列创建EXCEL工作簿
批量移动文件夹下指定文件
大家好，我是冷水泡茶，今天在EXCELHOME论坛上看到一篇求助的帖子：
楼主的需求是这样子的：
想到我们分享过拆分（Excel VBA 总表按项目拆分明细表/考勤表按部门拆分为单独文件）、分享过合并（Excel VBA 合并文件夹下所有EXCEL明细表），移动倒是值得试一下：
1、为了演示的需要，我们创建模拟文件：
Sub CreateFile() Dim FileSystem As Object Dim files As Object Dim file As Object Dim fileFolder As String Dim fileName As String Dim fileNumbers As Integer On Error Resume Next Application.ScreenUpdating = False fileNumbers = InputBox("请输入文件数量：", "输入文件数量", 10) numbers = CInt(fileNumbers) If numbers < 1 Then MsgBox "文件数量输入有误，必须是大于等于1的整数！" Exit Sub End If If Not wContinue("即将创建文件，此操作将先删除文件夹下所有文件！") Then Exit Sub Set fso = CreateObject("Scripting.FileSystemObject") fileFolder = ThisWorkbook.Path & "\A" Set files = fso.GetFolder(fileFolder).files For Each file In files fso.DeleteFile file.Path Next Set fso = Nothing For i = 1 To numbers fileName = i & ".xlsx" If Not IsFileExists(fileFolder & "\" & fileName) Then Workbooks.Add ActiveWorkbook.SaveAs fileName:=fileFolder & "\" & fileName ActiveWorkbook.Close End If Next Application.ScreenUpdating = True MsgBox "文件创建成功!"End Sub
代码解析：
（1）前面有一些检查，输入文件数量必须是大于等于1的整数
（2）通过FileSystemObject对象删除文件夹下所有文件，原来的思路是检查一下即将新建的文件存不存在，不存在才新建，这样速度更快些，但是为了确保文件夹下只有本次新建的文件，还是删除重建吧。
（3）在接下来的循环创建文件的代码中，仍然是有检查文件是否存在，理论上是不会有文件存在，但是以防万一出错嘛。
2、移动文件：
Sub MoveFilesInFolder() Dim FileSystem As Object Dim SourceFile As Object Dim destFile As String Dim SourceFolder As String, DestinationFolder As String Dim arrFile() Dim ws As Worksheet Dim lastRow As Integer On Error Resume Next Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row arrFile = ws.Range("A1:A" & lastRow) SourceFolder = ThisWorkbook.Path & "\A" DestinationFolder = ThisWorkbook.Path '确保源文件夹和目标文件夹存在 If Dir(SourceFolder, vbDirectory) = "" Then MsgBox "源文件夹不存在！", vbExclamation Exit Sub End If If Dir(DestinationFolder, vbDirectory) = "" Then MsgBox "目标文件夹不存在！", vbExclamation Exit Sub End If If Not wContinue("即将移动文件！") Then Exit Sub '创建文件系统对象 Set FileSystem = CreateObject("Scripting.FileSystemObject") '获取源文件夹下的所有文件 For i = 1 To UBound(arrFile, 1) If arrFile(i, 1) <> "" Then For Each SourceFile In FileSystem.GetFolder(SourceFolder).files If SourceFile.Name = arrFile(i, 1) & ".xlsx" Then destFile = DestinationFolder & "\" & SourceFile.Name If IsFileExists(destFile) Then Kill destFile End If '移动文件 FileSystem.MoveFile SourceFile.Path, destFile End If Next End If Next MsgBox "文件移动成功!"End Sub
代码解析：这个过程参考我们的Excel VBA 电子发票管理助手中的代码
（1）把要移动的文件名装入数组，即sheet1表的A列。
（2）仍然使用文件系统对象来移动文件。通过循环数组，把数组中的每一个值加上扩展名，就是正确的文件名，我们先检查它在目标文件夹中存不存在，如果存在则删除它，防止移动时出现覆盖提示，造成程序中断。
（3）把文件移动到目标文件夹。
3、两个自定义函数：
Function IsFileExists(iFileName) Dim myFile As Object Set myFile = CreateObject("Scripting.FileSystemObject") IsFileExists = myFile.FileExists(iFileName)End FunctionFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Dim a As Long Config = vbYesNo + vbDefaultButton2 + vbQuestion Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) & "否(N)返回！", Config, "请确认操作！") wContinue = Ans = vbYesEnd Function
好，今天就到这吧。欢迎点赞、留言、分享，谢谢大家，我们下期再会。