[已解决]如何批量修改同一文件夹内工作簿名及工作表名

stxyls

请教大师们：如何批量修改同一文件夹内工作簿名及工作表名，把修改好的工作簿放在新建的文件夹内。想要的结果请看附件中“新建文件夹”。（文件夹内工作簿有近百张，由于时间关系，只取7张来请教）

最佳答案

月排行榜 / 总排行榜

爱疯

2015-5-22 16:17

Sub Click()
    Dim p, f, str, t

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    str = ThisWorkbook.Name
    p = ThisWorkbook.Path & "\"
    f = Dir(p)


    Do While f <> ""
        If f <> str Then
            With Workbooks.Open(p & f)

                '1）修改工作表名
                t = .Sheets(1).Name
                t = VBA.Split(t, " ")(0)
                .Sheets(1).Name = t


                '2）修改工作簿名
                t = .Name
                t = Mid(t, InStr(t, "_") + 1)
                t = VBA.Split(t, " ")(0)
                .SaveAs p & "新建文件夹\" & t

                .Close False
            End With
        End If
        f = Dir
    Loop
End Sub

基础数据.rar (46.47 KB, 下载次数: 24)

2015-5-22 16:17 上传

点击文件名下载附件






1）没作检查
2）要确保 "新建文件夹" 已存在

跳转到最佳答案楼层

爱疯

Sub Click()
    Dim p, f, str, t

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    str = ThisWorkbook.Name
    p = ThisWorkbook.Path & "\"
    f = Dir(p)


    Do While f <> ""
        If f <> str Then
            With Workbooks.Open(p & f)

                '1）修改工作表名
                t = .Sheets(1).Name
                t = VBA.Split(t, " ")(0)
                .Sheets(1).Name = t


                '2）修改工作簿名
                t = .Name
                t = Mid(t, InStr(t, "_") + 1)
                t = VBA.Split(t, " ")(0)
                .SaveAs p & "新建文件夹\" & t

                .Close False
            End With
        End If
        f = Dir
    Loop
End Sub

基础数据.rar (46.47 KB, 下载次数: 24)

2015-5-22 16:17 上传

点击文件名下载附件






1）没作检查
2）要确保 "新建文件夹" 已存在

dsmch

1. Sub Macro1()
   
2. Dim mypath$$, wj$$, zf$$
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls")
   
7. Do While wj <> ""
   
8.     If wj <> ThisWorkbook.Name Then
   
9.         With Workbooks.Open(mypath & wj)
   
10.             zf = Split(.Sheets(1).Name)(0)
    
11.             .Sheets(1).Name = zf
    
12.             .SaveAs mypath & "新建文件夹" & zf & ".xls"
    
13.         End With
    
14.         ActiveWorkbook.Close 0
    
15.     End If
    
16.     wj = Dir
    
17. Loop
    
18. Application.DisplayAlerts = True
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

stxyls

谢谢两位老师指教，真神人也！

筱筱655696

学习了