工作簿批量改名_多级文件夹

Public jg
Sub 工作簿批量改名2()
    Dim oldName As String, newName As String, fileName
    Application.ScreenUpdating = False
    ar = getCustomerNameAndLastYuEByFullPath
    For x = 1 To UBound(jg)
        p1 = jg(x, 3)
        If Not IsEmpty(p1) Then
            olename = jg(x, 3)
            new_wbname = 新的工作簿名称(p1)
            newName = jg(x, 2) & "\" & new_wbname & ".xls"
            '                ActiveWorkbook.Close True
            Name olename As newName
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "OK"
End Sub

Function 新的工作簿名称(p)
    With GetObject(p)
        wbname = .Sheets("往来对账").[b2]
        .Close False
    End With
    新的工作簿名称 = wbname
End Function

Function getCustomerNameAndLastYuEByFullPath()
    Set dic_cust_yu_e_last = CreateObject("scripting.dictionary")
    sb& = 0
    SpFile$ = ".xl"
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择目标文件夹......"
        If .Show Then myPath$ = .SelectedItems(1) Else End
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(2000, 3)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path"
    tms = Timer: k = 0: Call ListAllFso002(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = ""
    '    Sheet1.[a1].Resize(k + 1, 4) = jg
    Sheet1.[a1].Resize(2000, 4) = jg
    [a1].CurrentRegion.AutoFilter Field:=1
    getCustomerNameAndLastYuEByFullPath = jg
End Function

Function ListAllFso002(myPath$, Optional sb& = 0, Optional SpFile$ = "") '递归检查子文件夹的过程代码
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then '如果模式为0或1、或指定了匹配文件要求，则遍历各个文件
        For Each F In fld.Files '用FSO方法遍历文件.Files
            t = False '匹配状态初始化
            n = InStrRev(F.Name, "."): fnm = Left(F.Name, n - 1): x = LCase(Mid(F.Name, n))
            If Err.Number Then Err.Clear
            If SpFile = " " Then 'Space 如果匹配要求为空则匹配全部
                t = True
            ElseIf SpFile Like ".*" Then '如果匹配要求为文件类型则
                If x Like SpFile Then t = True '当文件符合文件类型要求时匹配，否则不匹配
            Else '否则为需要匹配文件名称中的一部分
                If InStr(fnm, SpFile) Then t = True '如果匹配则状态为True
            End If
            If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld: jg(k, 3) = fld & "\" & fnm & x
        Next
        Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    For Each fd In fld.SubFolders '然后遍历检查所有子文件夹.SubFolders
        If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd: jg(k, 3) = fld & "\" & fnm & x
        If sb Mod 2 = 0 Then Call ListAllFso002(fd.Path, sb, SpFile)
    Next
End Function