Sub PodzialNaArkusze()

'sprawdzenie czy otwarte odpowiednie dokumenty
If ThisApplication.Documents.count = 0 Then MsgBox "Brak otwartych dokumentów": Exit Sub
If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then MsgBox "Otwarty dokument nie rysunkiem! ": Exit Sub

Dim oDoc As DrawingDocument
Set oDoc = ThisApplication.ActiveDocument

'Sprawdzenie czy otwary dokument ma wiecej niz jden arkusz
If oDoc.Sheets.count = 1 Then MsgBox "Arkusz posiada tylko jeden arkusz!": Exit Sub

'Nazwy nowych rysunkow
Dim i As Integer
Dim NeuName() As String
ReDim NeuName(1 To oDoc.Sheets.count)

Dim TN As String, ext As String
TN = Mid(oDoc.FullFileName, 1, InStrRev(oDoc.FullFileName, ".") - 1)
ext = Mid(oDoc.FullFileName, InStrRev(oDoc.FullFileName, "."))

For i = LBound(NeuName) To UBound(NeuName)
    NeuName(i) = TN & "-" & Replace(oDoc.Sheets.Item(i).name, ":", "_") & ext
    If NeuName(i) = "" Then MsgBox "Blad nazwy :" & NeuName(i): Exit Sub
    If Not Dir(NeuName(i)) = "" Then MsgBox "Plik o nazwie :" & NeuName(i) & " juz istnieje!": Exit Sub
Next i

'Robimy kopie rysunkow oraz usuwamy niepotrzebne arkusze
Dim oDocN As DrawingDocument
Dim sh As Sheet
For i = 1 To oDoc.Sheets.count
    ThisApplication.SilentOperation = True
        oDoc.Sheets.Item(i).Activate
        oDoc.SaveAs NeuName(i), True
        Set oDocN = ThisApplication.Documents.Open(NeuName(i))
                'usuwanie arkuszy
                For Each sh In oDocN.Sheets
                    If Not oDocN.ActiveSheet.name = sh.name Then sh.Delete
                Next sh
        oDocN.Save
        oDocN.Close
    ThisApplication.SilentOperation = False
    Set oDocN = Nothing
Next i
End Sub