求助-提取多个EXCEL表格 工作簿内容并修改工作簿名称，保存到同一excel表格中

li6313668

各位大神· 求助

现在有多张表格，每个表格里面有多个工作簿（我们的财务报表，大概有100+工作簿）
现在需求  把多个表格的 工作簿中的   <F01-资产负债表>    <F02-利润表>   <F03-现金流量表>   导入新的表格中（一张表格）   
名称修改成  <XXXX-资产负债表> <XXX-利润表>   <XXX-现金流量表>     
XXX为<Cover> 工作簿中 单位名称：后面的数据   
要求导入新表格工作簿的内容均为 值  不保留原多个表格里的公式
求大神帮忙· 小弟在这里跪谢！！！

表格 1 2 3 均为基础表格 需要里面的数据  

li6313668

各位大神· 求助
各位大神· 求助
各位大神· 求助

3190496160

Sub 导入()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ss = ThisWorkbook
For Each sh In Sheets
    If sh.Index > 1 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(lj & f, 0)
        mc = wb.Worksheets("Cover").[b11]
        For Each sht In wb.Worksheets(Array("F01-资产负债表", "F02-利润表", "F03-现金流量表"))
            sht.Copy after:=ss.Worksheets(ss.Worksheets.Count)
            With ss.Worksheets(ss.Worksheets.Count)
                .Name = mc & Split(sht.Name, "-")(1)
                '.UsedRange.Value = .UsedRange.Value''目前工作表有保护，这句代码不能运行，暂时注释掉
            End With
        Next sht
        wb.Close False
    End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

数据导入.rar (1.68 MB, 下载次数: 5)

2023-4-4 11:11 上传

点击文件名下载附件

3190496160

3190496160

需要导入的文件中的工作表有工作表保护，公式数值化的代码没法运行，目前的代码仅供参考

li6313668

3190496160 发表于 2023-4-4 11:12
需要导入的文件中的工作表有工作表保护，公式数值化的代码没法运行，目前的代码仅供参考

收到· 非常感谢· 已经可以省去一些工作时间了·  感谢感谢