请大神帮忙修正代码。该代码用于从指定工作薄提取指定三个工作表生成工作薄。谢谢

jstzyb

Sub 全过程预算书导出()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayAlerts = 0 '不提示保存本工作表
Dim lj As String
Dim nm As String
Dim dirname As String
  lj = ActiveWorkbook.Path
  nm = ActiveWorkbook.Name
  n = 0
  dirname = Dir(lj & "/*.xls*")
Do While dirname <> ""
If dirname <> nm Then
  n = n + 1
  Workbooks.Open Filename:=lj & "\" & dirname
  Sheets("项目信息").Visible = True
  Sheets("甲供材格式清单").Visible = True
  Sheets("拆旧材料格式清单").Visible = True
  filesavename = Sheets("封面").Range("D3")
  ipath = ThisWorkbook.Path & "\"
  For Each sht In ActiveWindow.SelectedSheets
  sht = Sheets("项目信息").Copy
        Sheets("项目信息").UsedRange.Value = ActiveSheet.UsedRange.Value      
        Sheets("甲供材格式清单").Copy
        Sheets("甲供材格式清单").UsedRange.Value = ActiveSheet.UsedRange.Value    '到这里提至下标越界错误
        Sheets("拆旧材料格式清单").Copy
        Sheets("拆旧材料格式清单").UsedRange.Value = ActiveSheet.UsedRange.Value
        thename = filesavename & "_预算书"
                ActiveWorkbook.SaveAs ipath & thename & ".xlsx"
        ActiveWindow.Close
    Next
  Workbooks(dirname).Close False
End If
dirname = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "本次总计生成了： " & n & " 预算书"
End Sub


请大神帮忙指正，谢谢。

abc123281

没有明确的要求  针对你提供的代码  作了一下修改

Sub 全过程预算书导出()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim mypath As String
Dim myname As String
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.xl*")
Do While myname <> ""
  If myname <> ThisWorkbook.Name Then
    n = n + 1
    Set wb = Workbooks.Open(mypath & myname)
    With wb
      arr = Array("项目信息", "甲供材格式清单", "拆旧材料格式清单")
      filesavename = .Worksheets("封面").Range("D3")
     .Worksheets(arr).Copy
      Set wbadd = ActiveWorkbook
      wbadd.SaveAs ThisWorkbook.Path & "\预算书\" & "预算书" & filesavename
      wbadd.Close
    End With
    wb.Close
  End If
myname = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "本次总计生成了： " & n & " 个预算书", 64
End Sub

abc123281

抓取模版123.rar (226.54 KB, 下载次数: 4)

2019-3-18 16:16 上传

点击文件名下载附件

jstzyb

多谢大神。已测试成功。