自动生成多个岗位说明书excel文件

木图天

岗位说明书内容相同，求助：仅变化一下岗位编码，生成多个单独的岗位说明书excel文件。

limonet

Sub limonet()
    Dim i%, Arr As Variant
    Arr = Sheet2.Range("B2:C" & Sheet2.Range("C" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(Arr)
        [B4] = Arr(i, 1): [E4] = Arr(i, 2)
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\岗位说明书-" & Arr(i, 2) & ".xlsx"
    Next i
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set sh = ThisWorkbook.Sheets("岗位说明书")
   
6.     With Sheets("岗位编码")
   
7.         r = .Cells(Rows.Count, 3).End(3).Row
   
8.         arr = .[a1].Resize(r, 3)
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 3)
    
12.         fn = sh.Name & " - " & s
    
13.         sh.Copy
    
14.         Set wb = ActiveWorkbook
    
15.         wb.Sheets(1).[e4] = s
    
16.         wb.SaveAs p & fn
    
17.         wb.Close
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20.     MsgBox "OK！"
    
21. End Sub
    

复制代码

limonet

关键字：savecopyas

木图天

ykcbf1100 发表于 2024-9-2 15:58
参与一下。。。

非常感谢！

gwjkkkkk

Option Explicit
Sub test0()
    Dim ar, i&, strFileName$, strPath$, wks As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    strPath = ThisWorkbook.Path & "\"
    ar = [A1].CurrentRegion.Value
    Set wks = Worksheets("岗位说明书")
   
    For i = 2 To UBound(ar)
        wks.Copy
        With ActiveWorkbook
            strFileName = strPath & "岗位说明书 - " & ar(i, 3)
            With .Worksheets(1)
                .Range("E4").Value = ar(i, 3)
            End With
            .SaveAs strFileName
            .Close
        End With
    Next i
   
    Set wks = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

blackttea1

好的程序，谢谢分享