求：一个能根据数据表和3张不同子表格，批量生成3张子表格的代码

7547854

表达可能不太明白，请看描述

7547854

生成图示的文件类型

7547854

gwjkkkkk

Sub TSET()
    Dim strFileName$, strPath$, wkb As Workbook, arr, i&
    Application.ScreenUpdating = False
    arr = [A1].CurrentRegion
    strPath = ThisWorkbook.Path & "\"
    For i = 2 To UBound(arr)
       strFileName = strPath & arr(i, 3)
       Sheets(Array(Sheets(2).Name, Sheets(3).Name, Sheets(4).Name)).Copy
       Set wkb = ActiveWorkbook
            For Each wks In wkb.Sheets
               wks.[G12] = arr(i, 1)
               wks.[S12] = arr(i, 2)
            Next
       wkb.SaveAs strFileName
       wkb.Close True
    Next i
    Set wkb = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请楼主参考 。。。

3190496160

Sub 生成表格()
Application.ScreenUpdating = False
With Sheets("数据表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:c" & rs)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 3)) <> "" Then
        mc = ar(i, 3)
        m = 0
        For Each sh In Sheets(Array("沟槽开挖", "沟槽支护", "管道基础"))
            m = m + 1
            If m = 1 Then
                sh.Copy
                Set wb = ActiveWorkbook
                With wb.Worksheets(1)
                    .[g12] = ar(i, 1)
                    .[s12] = ar(i, 2)
                End With
            Else
                sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
                With wb.Worksheets(wb.Worksheets.Count)
                    .[g12] = ar(i, 1)
                    .[s12] = ar(i, 2)
                End With
            End If
        Next sh
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & ".xlsx"
        wb.Close
    End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助：批量生成独立文件.rar (34.49 KB, 下载次数: 10)

2022-11-17 20:26 上传

点击文件名下载附件

7547854

3190496160 发表于 2022-11-17 20:26

谢谢，谢谢

7547854

gwjkkkkk 发表于 2022-11-17 19:33
请楼主参考 。。。

谢谢，谢谢，是这样

7547854

新的问题，望能帮忙看看