Skapa arbetsböcker i Excel efter mall?

Så här långt har jag kommit:

sub uppdatera()

    For Each Worksheet In ActiveWorkbook.Sheets

            'Testalert
            MsgBox Worksheet.Name
            MsgBox "Kopiera"
     
            
    ThisWorkbook.Worksheets(Array(Worksheet.Name, "KUND")).Copy
    
    Next Worksheet

    Exit Sub

Denna fungerar:
ActiveWorkbook.SaveCopyAs Filename:=Worksheet.Name & ".xls"

Tyckte att typ detta skulle fungera, men icke:

ThisWorkbook.Worksheets(Array(Worksheet.Name, "KUND")).saveCopyAs Worksheet.Name & ".xls"

Något tips till att sättas namn på det jag kopierar?

Jag har kommit så långt att jag kan se vilka arbetsböcker som redan finns resp. vilka som måste skapas.
Att bara skapa en tom arbetsbok i sig är inget problem, mao återstår överkopierandet av mina blad...

solbulle,

Här får du kod att arbeta med. Den är medveten okommenterad varför du få använda dig av F1-tangenten om det är något som är oklart:

Option Explicit
Option Base 1

Sub Add_Workbook_Sheets()
'© 2002 Alla rättigheter XL-Dennis
Dim wbMall As Workbook
Dim wsBlad As Worksheet
Dim stBNamn() As String
Dim i As Long, j As Long, k As Long

Set wbMall = ThisWorkbook
j = wbMall.Worksheets.Count

For i = 1 To j
    If Not Worksheets(i).Name = "Funktioner" Then
        ReDim Preserve stBNamn(i)
        stBNamn(i) = wbMall.Worksheets(i).Name
    End If
Next i

Application.ScreenUpdating = False

For k = 1 To UBound(stBNamn)
    If Not FileExists(stBNamn(k)) Then
        Workbooks.Add xlWBATWorksheet
        With wbMall
            .Worksheets("Funktioner").Copy Before:=ActiveWorkbook.Worksheets(1)
            .Worksheets(stBNamn(k)).Copy Before:=ActiveWorkbook.Worksheets(1)
        End With
        Set wsBlad = ActiveSheet
        On Error Resume Next
        wsBlad.Cells.SpecialCells(xlCellTypeConstants, 1).ClearContents
        On Error GoTo 0
        With ActiveWorkbook
            .SaveAs stBNamn(k)
            .Close
        End With
    End If
Next k

Application.ScreenUpdating = True

End Sub

Function FileExists(strFileName As String) As Boolean
'© 2002 Alla rättigheter XL-Dennis
FileExists = False
ChDir ThisWorkbook.Path
If Dir(strFileName) <> "" Then
    FileExists = True
End If
End Function

Jag bugar & bockar, ska kika igenom och testa koden.
Den har vissa likheter med den kod jag kommit fram till men jag ser uppenbara förbättringar samt prestandahöjningar.
Sen som sagt kommer nog F1 till användning...

Jag har kommit en bit på väg, vet inte riktigt om det är rätt väg men det snurrar något så när i alla fall.
Jag får verkligen tacka för den kod jag fått.

Problemet som jag har nu är att när jag kopierar mina blad från min mall så blir det en massa länkar till den "gamla" sidan.
Vet inte riktigt om raden:

wsBlad.Cells.SpecialCells(xlCellTypeConstants, 1).ClearContents

kan hjälpa mig med det?

Annars tänkte jag mig att kanske att man kunde skriva om XL-Dennis sub Ta_Bort_Externa_Länkar() så att den endast "klipper bort" filnamnet ur länken, det mellan [ och ].

Hur kan det göras tro?

Vidare, sista grejen nu, kan jag i detta script sätta referenser (typ i verktygsmenyn) mha VBA-kod?

Sub Ta_Bort_Externa_Länkar()
'© 2001 Alla rättigheter XL-Dennis
Dim oObjekt As Object
Dim wsBlad As Worksheet

On Error Resume Next

For Each wsBlad In ActiveWorkbook.Worksheets
   For Each oObjekt In wsBlad.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
     If InStr(oObjekt.Formula, "[") Or InStr(oObjekt.Formula, "!") Then
        oObjekt.Value = ""
     End If
   Next
Next
End Sub

Hela mitt vackra kodschabrak:

Option Explicit
Option Base 1

Sub Add_Workbook_Sheets()
'© 2002 Alla rättigheter XL-Dennis
Dim wbMall As Workbook
Dim wsBlad As Worksheet
Dim stBNamn() As String
Dim i As Long, j As Long, k As Long

Set wbMall = ThisWorkbook
j = wbMall.Worksheets.Count

For i = 1 To j
    If Not Worksheets(i).Name = "PRISER" Then
    If Not Worksheets(i).Name = "KUND" Then
    If Not Worksheets(i).Name = "KÖR" Then
    If Not Worksheets(i).Name = "SQL" Then
        ReDim Preserve stBNamn(i)
        stBNamn(i) = wbMall.Worksheets(i).Name
    End If
    End If
    End If
    End If
Next i

Application.ScreenUpdating = False

ActiveWorkbook.VBProject.VBComponents("Modul1").Export (ThisWorkbook.Path & "\XL.bas")
   
For k = 1 To UBound(stBNamn)

If stBNamn(k) <> "" Then
     
    '//Nytt stycke, OM bladet finns.
    '//Skall bladet med kundnummret kopieras in.
    
    If FileExists(stBNamn(k) & ".xls") Then
        
    'Testmess
        MsgBox (stBNamn(k) & ".xls") & " Finns!"
   
        Workbooks.Open (stBNamn(k) & ".xls")
    
            With wbMall
                .Worksheets(stBNamn(k)).Copy Before:=ActiveWorkbook.Worksheets(1)
            End With

            '//På ett el. annat sätt måste länkarna brytas.
            'wsBlad.Cells.SpecialCells(xlCellTypeConstants, 1).ClearContents
            
            '//Denna variant plockar bort det gamla PRISER-bladet och lägger in ett nytt samt sparar sen boken.
            Application.DisplayAlerts = False
            ActiveWorkbook.Worksheets("PRISER").Delete
            ActiveWorkbook.Worksheets(stBNamn(k)).Name = "PRISER"
            
            With ActiveWorkbook
                .Save
                .Close savechanges:=True
            End With
            Application.DisplayAlerts = True

    End If

   If Not FileExists(stBNamn(k) & ".xls") Then
	'Testmess
        MsgBox (stBNamn(k) & ".xls") & " Finns inte!"
            Workbooks.Add xlWBATWorksheet
            With wbMall
                .Worksheets("KUND").Copy Before:=ActiveWorkbook.Worksheets(1)
                .Worksheets("SQL").Copy Before:=ActiveWorkbook.Worksheets(1)
                .Worksheets(stBNamn(k)).Copy Before:=ActiveWorkbook.Worksheets(1)
            End With
    
    ActiveWorkbook.VBProject.VBComponents.Import (ThisWorkbook.Path & "\XL.bas")
       
            ActiveWorkbook.Worksheets(stBNamn(k)).Name = "PRISER"
            'Läge att fimpa eventuella skrotblad, typ "Blad1"?

            Set wsBlad = ActiveSheet
            On Error Resume Next
            '//Denna rad raderar allt förutom funktioner. -Avvakta!
            'wsBlad.Cells.SpecialCells(xlCellTypeConstants, 1).ClearContents
            On Error GoTo 0
            With ActiveWorkbook
                .SaveAs stBNamn(k)
                .Close
            End With
        End If

End If
    
Next k

Application.ScreenUpdating = True

'// Ta bort den tillfälligt exporterade modulen.
Kill (ThisWorkbook.Path & "\XL.bas")

End Sub

Function FileExists(strFileName As String) As Boolean
'© 2002 Alla rättigheter XL-Dennis
FileExists = False
ChDir ThisWorkbook.Path
If Dir(strFileName) <> "" Then
    FileExists = True
End If
End Function

solbulle,

Tack för att vi får se hela mästerverket :)

Då du har valt att ställa frågan såväl här på wF som på IDG:s E-forum vill jag be dig i all vänlighet att även låta tråden på E-forumet leva vidare parallellt med tråden här.

Jag kompletterar tråden där med mina svar här.

Lägga till kommando i verktygsmenyn:

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
CommandBars(1).FindControl(ID:=30007).Controls("Önskad titel").Delete

End Sub

Private Sub Workbook_Open()
Dim cbVerktyg As CommandBar
Dim cbKnapp As CommandBarButton

Set cbVerktyg = CommandBars(1).FindControl(ID:=30007)

Call Ta_Bort

If cbVerktyg Is Nothing Then
    MsgBox "Verktygsmenyn saknas - Kan ej skapa alternativet.", vbCritical
    Exit Sub
Else
    Set cbKnapp = cbVerktyg.Controls.Add(Type:=msoControlButton)
    With cbKnapp
        .Caption = "Önskad titel"
        .FaceId = "önskad knappbild"
        .OnAction = "Ditt makro"
        .BeginGroup = True
    End With
End If

End Sub

Sub Ta_Bort()
On Error Resume Next
CommandBars(1).FindControl(ID:=30007).Controls("Önskad titel").Delete
End Sub

Omvandla länkvärden till konstanta värden:

Sub Omvandla_Lankar_Varden()
'© Alla rättigheter XL-Dennis
Dim oObjekt As Object
Dim wsBlad As Worksheet
Dim iAntalO As Integer, iAntalF As Integer, iAntalN As Integer
On Error Resume Next

Application.ScreenUpdating = False

For Each wsBlad In ActiveWorkbook.Worksheets
    For Each oObjekt In wsBlad.DrawingObjects
        If InStr(oObjekt.OnAction, "!") Then
            oObjekt.OnAction = ""
            iAntalO = iAntalO + 1
        End If
    Next
    
    For Each oObjekt In wsBlad.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
        If InStr(oObjekt.Formula, "[") Or InStr(oObjekt.Formula, "!") Then
            oObjekt.Value = oObjekt.Value
            If Err Then
                iAntalF = iAntalF
            Else
                iAntalF = iAntalF + 1
            End If
        End If
    Next
Next

For Each oObjekt In ActiveWorkbook.Names
    If InStr(oObjekt.RefersToLocal, "!") Then
        oObjekt.Delete
        iAntalN = iAntalN + 1
    End If
Next

If Application.Sum(iAntalO, iAntalF, iAntalN) = 0 Then
    MsgBox "Inga länkar hittades!", vbInformation, "Ta bort länkar i aktiv arbetsbok"
Else
    MsgBox iAntalO & " st länkar till objekt togs bort." & Chr(10) _
       & iAntalF & " st celllänkar omvandlades till värden." & Chr(10) _
       & iAntalN & " st länknamn togs bort.", vbInformation, "Ta bort länkar i aktiv arbetsbok"
End If
Application.ScreenUpdating = True
End Sub

Ta bort arbetsblad:

Sub Ta_Bort_Blad()
Dim wbBok As Workbook
Dim wsBlad As Worksheet

Set wbBok = ThisWorkbook
Set wsBlad = wbBok.Worksheets("Blad1")

Application.DisplayAlerts = False
wsBlad.Delete
Application.DisplayAlerts = True

End Sub

OBS! Jag har ej testat koden.

Så här fick det bli. (Sen blir det väl modifieringar under resans gång - som alltid.)
Jag använder mig nu av en liten "mallfil" när jag bygger nya filer, det verkar vara den bästa lösningen.
Det största problemet jag tycker mig ha med Excel är alla dessa länkningar som följer med kors och tvärs och emmellanåt bryts (="phantom link")
Tycker det borde finnas, (eller att jag borde veta) hur man LÄTT ser vilka celler som har referenser och länkar utanför det egna bladet.
-jo det går att se med hjälp av kod, men det borde gå (gör?) att se ändå....

Hur som helst ville jag egentligen bara visa hur det hela blev:

Sub Add_Workbook_Sheets()
'© 2002 Alla rättigheter XL-Dennis
' Modifierad av Solbulle
Dim wbMall As Workbook
Dim wsBlad As Worksheet
Dim stBNamn() As String
Dim i As Long, j As Long, k As Long
Dim oObjekt As Object
Dim rnOmradeKopiera As Range
Dim finns_blad As Variant
Dim msg As String
Dim iAtgard As Variant
Dim stbNamnarr As String

Set wbMall = ThisWorkbook
j = wbMall.Worksheets.Count

For i = 1 To j
    If Not Worksheets(i).Name = "PRISER" Then
    If Not Worksheets(i).Name = "KUND" Then
    If Not Worksheets(i).Name = "KÖR" Then
    If Not Worksheets(i).Name = "Sql" Then
        ReDim Preserve stBNamn(i)
        stBNamn(i) = wbMall.Worksheets(i).Name
        finns_blad = True
    End If
    End If
    End If
    End If
Next i

If finns_blad = True Then

Application.ScreenUpdating = False

For k = 1 To UBound(stBNamn)

If stBNamn(k) <> "" Then

stbNamnarr = stbNamnarr & stBNamn(k) & vbCrLf
'//OM bladet finns.

    Set rnOmradeKopiera = ThisWorkbook.Worksheets(stBNamn(k)).Range("A1:J300")
       
    If FileExists(stBNamn(k) & ".xls") Then
        
        'Testmess
        'MsgBox (stBNamn(k) & ".xls") & " Finns!"
   
        Workbooks.Open (stBNamn(k) & ".xls")
    
       Set rnOmradeKopiera = ThisWorkbook.Worksheets(stBNamn(k)).Range("A1:J300")

       rnOmradeKopiera.Copy ActiveWorkbook.Worksheets("PRISER").Range("A1")

        Application.DisplayAlerts = False
        With ActiveWorkbook
            .Save
            .Close savechanges:=True
        End With
        Application.DisplayAlerts = True

    End If
    
'//OM bladet INTE finns.
    If Not FileExists(stBNamn(k) & ".xls") Then
        'Testmess
        'MsgBox (stBNamn(k) & ".xls") & " Finns inte!"
        
        Workbooks.Open ("mall.xls")

       rnOmradeKopiera.Copy ActiveWorkbook.Worksheets("PRISER").Range("A1")

    ActiveWorkbook.Worksheets("PRISER").Visible = False
            
            Application.DisplayAlerts = False
            With ActiveWorkbook
                .SaveAs stBNamn(k)
                .Close
            End With
            Application.DisplayAlerts = True
        End If
End If
    
Next k

Application.ScreenUpdating = True

msgbox "Klar."

Else

msgbox "Inga blad att kopiera."

End If

End Sub

Function FileExists(strFileName As String) As Boolean
'© 2002 Alla rättigheter XL-Dennis
FileExists = False
ChDir ThisWorkbook.Path
If Dir(strFileName) <> "" Then
    FileExists = True
End If
End Function