遍历子文件夹，根据规则拷贝指定文件到指定目录并重命名

zp602

各位老师好！我对VBA不太熟悉，能否帮忙编一段代码，解决文件重命名的问题。谢谢！
遍历子文件夹，根据规则重新命名指定文件，并拷贝到指定目录
1.子文件夹可能有几百个；
2.每个子文件夹(不确定文件名)都包含一个.xls文件（不确定文件名），同时包含一个.cdr或一个.ai的文件（不确定文件名）；
3.每个.xls文件的A2单元格，是一个由数字和字母组成的字符串，称之为“物料编码”,“物料编码”不会重复；
4.想实现的功能：
  复制子文件夹下面的.cdr或.ai文件到素材文件夹，用A2单元格“物料编码”的字符串重命名该文件，例如：
  “物料编码”为12345678，cdr文件为abcd123.cdr，拷贝abcd123.cdr到“素材”文件夹并重命名为12345678.cdr
  如果子文件夹里没有.cdr文件，一定有.ai文件，那么拷贝.ai文件到素材文件夹，用“物料编码”对.ai重命名。
  对所有的子文件夹都进行以上操作。

约定的童话

MARK学习一下，这个还是有难度的

乐乐2006201505

在“遍历文件夹并根据规则重新命名”文件夹中新建个Excel文件，将下面代码粘贴即可。
Sub 遍历子文件夹，根据规则拷贝指定文件到指定目录并重命名()
  Dim i&, n&, MyPath$
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '**********************************************************************************
  Rem 提取路径名及文件名
  Set dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
  MyPath = ThisWorkbook.Path
  dic.Add (MyPath & "\"), ""
  i = 0
  Do While i < dic.Count
    ke = dic.keys   '开始遍历字典
    Filename = Dir(ke(i), vbDirectory)    '查找目录
      Do While Filename <> ""
        If Filename <> "." And Filename <> ".." Then
          If (GetAttr(ke(i) & Filename) And vbDirectory) = vbDirectory Then    '如果是次级目录
            dic.Add (ke(i) & Filename & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
          End If
        End If
        Filename = Dir    '继续遍历寻找
      Loop
    i = i + 1
  Loop
  i = 0
'**********************************************************************************
  struser = MyPath & "\"
  For Each ke In dic.keys '以查找总表所在文件夹下所有excel文件为例
'    m = m + 1
    If InStr(ke, "素材") Then GoTo 1
      myfliename = Dir(ke & "*.*")  '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
      Do While myfliename <> ""
        If myfliename <> Liwai Then  '排除例外文件
          If myfliename <> ThisWorkbook.Name And myfliename <> "求助说明.txt" Then
            If InStr(myfliename, ".xls") Or InStr(myfliename, ".xlsx") Then
              Set wb = Workbooks.Open(ke & myfliename)
              With wb
                nm = .Sheets(1).Range("a2").Value
                .Close
              End With
            End If
            If Dir(ke & myfliename, ".cdr") <> "" Or Dir(ke & myfliename, ".ai") <> "" Then
              If InStr(myfliename, ".cdr") Then
                FileCopy ke & myfliename, struser & "素材\" & nm & ".cdr"
              End If
              If InStr(myfliename, ".ai") Then
                FileCopy ke & myfliename, struser & "素材\" & nm & ".ai"
              End If
            End If
          End If
        End If
        myfliename = Dir
      Loop
1:
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

乐乐2006201505

代码需审核，耐心等待。刚给你私发了，估计你也没报什么大的希望，或者不急用。处于离线状态。心有点凉。

zp602

乐乐2006201505 发表于 2020-3-12 21:32
代码需审核，耐心等待。刚给你私发了，估计你也没报什么大的希望，或者不急用。处于离线状态。心有点凉。

我一直在忙于工作，所以没有及时在线，感谢你抽出宝贵的时间帮我写代码，十分感谢！

zp602

乐乐2006201505 发表于 2020-3-12 21:31
在“遍历文件夹并根据规则重新命名”文件夹中新建个Excel文件，将下面代码粘贴即可。
Sub 遍历子文件夹， ...

乐乐老师，我在使用过程中发现重命名出错了。原始文件.cdr和.ai的文件名，包含“#”、“$”、"%"等特殊符号，执行代码后重命名的文件出现2种情况：1.缺失；2.重复。

怀疑是特殊符号引起的，我将文件手动重命名为正常文件名，再执行代码，同样会出现以上错误。
具体情况见附件，麻烦你有空帮我看一下，谢谢！

约定的童话

乐乐2006201505 发表于 2020-3-12 21:31
在“遍历文件夹并根据规则重新命名”文件夹中新建个Excel文件，将下面代码粘贴即可。
Sub 遍历子文件夹， ...

这思路清奇啊，妙用字典存储，实在是高

opel-wong

zp602 发表于 2020-3-13 17:02
乐乐老师，我在使用过程中发现重命名出错了。原始文件.cdr和.ai的文件名，包含“#”、“$”、"%"等特殊符 ...

VBA还加密码？

zp602

opel-wong 发表于 2020-3-14 09:40
VBA还加密码？

对不起，重新上传了。

zp602

乐乐2006201505 发表于 2020-3-12 21:31
在“遍历文件夹并根据规则重新命名”文件夹中新建个Excel文件，将下面代码粘贴即可。
Sub 遍历子文件夹， ...

乐乐老师，请再帮我看一下。我上传3个出错的示例，其中一个只修改cdr文件且保证了所有文件名不重复，代码执行改错了文件名，出错的文件夹是39283438806S和38114408893S。