将文件名相同后缀不同的文件分类到同名文件夹中

如下图所示，在【素材】文件夹下有若干个文件，其中有些文件的文件名相同，但是后缀不同。比如，A项目就有3个同名文件，分别是word文档，excel文件和ppt文件。同样地，B项目也有2个同名文件。

现在的要求是将相同文件名的文件分类到同名文件夹中，当点击按钮后，就在【素材】文件夹下创建了3个文件夹，并且每个文件夹中已经包含了相应的文件。

这个效果是用vba代码做的。代码如下，可左右滑动查看：

Sub 合并同名文件到同一文件夹中() Dim lj$, file$, folder$ Dim arr(), n, i lj = "C:\Users\Dell\Desktop\素材\" '素材文件夹的路径 file = Dir(lj) '利用dir函数取出素材文件夹下的第一个文件名 Do While file <> "" '如果文件名不为空，则进入do...loop循环 n = n + 1 '文件数累加1 ReDim Preserve arr(1 To n) '重定义数组arr的大小，并保留之前的数据 arr(n) = file '将文件名写入数组相应的位置 file = Dir '利用不带参数的dir遍历后面的文件名 Loop If n > 0 Then '如果文件个数大于0，则进入for...next循环 For i = 1 To UBound(arr) '开始循环 file = arr(i) '从数组中取出文件名，赋给变量file folder = Left(file, InStr(file, ".") - 1) '提取文件名(不含后缀),赋给变量folder If Dir(lj & folder, vbDirectory) = "" Then '判断文件夹是否存在，若不存在，则 MkDir lj & folder '新建文件夹 End If FileCopy lj & file, lj & folder & "\" & file '将文件复制到文件夹中 Next i End IfEnd Sub

方便观看的代码如下：

链接：

https://pan.baidu.com/s/1zxIMlhGeLj626GhmUA_HQw

提取码：21wd