Aktivere Designtilstand med makro

Mit problem er nedenstående makro som opretter et nyt ark og derefter kopiere en master over i det, men Excel går fuldstændig i stå og jeg kan kun lukke igen ved hjælp af Windows Jobliste.

Sub AddWorksheetExample()
Range("o2").Select
    Dim wksNewSheet    As Excel.Worksheet
    Dim wksNewSheets    As Excel.Worksheet
    detteark = ActiveSheet.Name
    navn = ActiveCell.Value
            Set wksNewSheet = Worksheets.Add
        wksNewSheet.Name = navn
            Sheets(detteark).Activate
        Selection.ClearContents
    Sheets("Master2").Select
    Selection.Copy
    wksNewSheet.Select
    Cells.Select
    ActiveSheet.Paste
End Sub


VH.

Michael

Lidt modficeret - prøv:
Sub AddWorksheetExample()
Dim wksNewSheet    As Excel.Worksheet
Dim wksNewSheets    As Excel.Worksheet

    Range("A1").Select
    detteark = ActiveSheet.Name
    navn = ActiveCell.Value
            Set wksNewSheet = Worksheets.Add
        wksNewSheet.Name = navn
            Sheets(detteark).Activate
        Selection.ClearContents
       
    Sheets("Ark2").Select
    ActiveSheet.Cells.Select
    Selection.Copy
   
    wksNewSheet.Select
    ActiveSheet.Range("A1").Select
    ActiveCell.PasteSpecial
End Sub

Tak for forsøget supertekst, men den gør desværre det samme som min, hele arket låser og så er der kun en måde at lukke ned på...

VH.

Michael

prøv:
Sub addArk()
Worksheets.Add.Name = Range("O2")
detteark = ActiveSheet.Name
Sheets("Master2").Select
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy Sheets(detteark).Range("A1")
End Sub

Hej excelent, kan man få din kode til også at kopiere celle størrelserne med?

Din kode låser ikke arket som tidligere, har dog fundet ud af at det var en kode der sikre tal indtastning i visse celler, der lavede ravage. Den er fjernet nu da der har været problemer med den før også.

VH.

Michael

ja
men jeg tænkte på om det ikke var nemmere blot at lave en kopi af Master2, og så ændre navnet bagefter - alt via kode naturligvis.

Hvis det nye ark alligevel skal være som Master2 ?

Sub AddArk2()
Sheets("Master2").Copy After:=Sheets("Master2")
ActiveSheet.Name = [Ark1!O2]
End Sub

ret Ark1 i linie 3 til det arknavn hvor du henter ny arknavn

Hmm... ikke helt. Måden arket virker på:

Jeg står på "Index" siden i celle "o2" taster et nr. (som bliver det nye arks nr.) trykker på en "opret knap" på siden, hvor makroen så skal kopiere "Master2" over i det nye ark.

Din første kode virkede også fint, bortset fra at den ikke kopiere celle størrelserne med fra "Master2"

VH.

Michael

Nu virker det, koden ser sådan her ud:

Sub AddWorksheetExample()
Range("o2").Select
    Dim wksNewSheet    As Excel.Worksheet
    Dim wksNewSheets    As Excel.Worksheet
    detteark = ActiveSheet.Name
    navn = ActiveCell.Value
            Set wksNewSheet = Worksheets.Add
        wksNewSheet.Name = navn
            Sheets(detteark).Activate
        Selection.ClearContents
    Sheets("Master2").Select
    Selection.Copy
    wksNewSheet.Select
    Cells.Select
    ActiveSheet.Paste
End Sub



Koden der har drillet fra starten så sådan her ud:

'Sikre rigtig indtastning
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("Q27")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AB27")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("F49")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("Q37")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("Q49")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("Q53")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AB37")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AM19")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("F66:F70")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("Q66:Q70")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AB66:AB70")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AM66:AM70")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AX66:AX70")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If

If Not Intersect(Target, Range("AX72")) Is Nothing Then
If Not IsNumeric(Target) Then
Target = ""
MsgBox " Tast tal !!!"
Target.Select
End If
End If
End Sub


VH.

Michael

Den lange kode burde kunne krympes ned til

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Range("Q27,AB27,F49,Q37,Q49,Q53,AB37,AM19,F66:F70,Q66:Q70,AB66:AB70,AM66:AM70,AX66:AX70,AX72")) Is Nothing Then
        If Not IsNumeric(Target) Then
            Target = ""
            MsgBox " Tast tal !!!"
            Target.Select
        End If
    End If
End Sub


For at forhindre automatiske koder i at køre, mens man kører en normal makro, så gør sådan

Sub AddWorksheetExample()

Application.EnableEvents = False

Range("o2").Select
    Dim wksNewSheet    As Excel.Worksheet
    Dim wksNewSheets    As Excel.Worksheet
    detteark = ActiveSheet.Name
    navn = ActiveCell.Value
            Set wksNewSheet = Worksheets.Add
        wksNewSheet.Name = navn
            Sheets(detteark).Activate
        Selection.ClearContents
    Sheets("Master2").Select
    Selection.Copy
    wksNewSheet.Select
    Cells.Select
    ActiveSheet.Paste

Application.EnableEvents = True


End Sub

Tak for input, vender lige tilbage i aften, der er noget "hus vedligeholdelse" der venter ;o)

VH.

Michael

Ja det var en lang "husvedligeholdelse" og er ikke en gang færdig endnu :o) men har da fået tid til at kikke lidt på det.

Og det sidste kabbak er kommet med her virker bare helt perfekt, mange tak for det.

Er dog lidt i tvivl omkring pointene, for excelent skal også ha´ noget ros, for det var hans kode der ledte mig på rette vej. Kan man dele pointene ?

TAK for hjælpen alle...

VH.

Michael

et svar ;-))

Selvfølgelig kan vi dele, giv de fleste til excelent, han gør et excellent arbejde her på eksperten.

Takker og bukker.. kan så sige at det er jeg bestemt ikke alene om :-)