Få Makro til at kopiere makro til nyt excel ark

Her er et eksempel på hvordan man skriver en makro i den aktive projektmappe i det aktive arks kodemodul

Det er bare at skrive koden.

se om du kan rette det til


Public Sub Flyt_Markeringskode_til_AktiveArk()
    Code = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & vbCrLf
    Code = Code & "    Cells.Interior.ColorIndex = xlNone" & vbCrLf
    Code = Code & "    ActiveCell.EntireRow.Interior.ColorIndex = 19" & vbCrLf
    Code = Code & "End Sub"

    With ActiveWorkbook.VBProject. _
        VBComponents(ActiveSheet.Name).CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With
End Sub

Jeg har prøvet at kopier koden ind i et ark for at se om den virker inden jeg begynder er rette den til.
Jeg er stadig på begynder stadiget med VBA.

Men da jeg prøver at køre den uden at ændre noget i den stopper den og markere disse linier gul i Debug mode:

With ActiveWorkbook.VBProject. _
        VBComponents(ActiveSheet.Name).CodeModule

Hvad gør jeg galt?

Hvilken version af Excel bruger du... 2007 eller 2010 ??

Hvis det er tilfældet skal tillade denne slags kode specielt.

For 2010 Englesk gøres det således:

File -> Options -> Trust Center -> Trust Center Settings -> Macro Settings
Sæt V ved "Trust access to the VBA project object model"

Jeg bruger version 2003.

Jeg har ikke rettet noget i selve den formel som jeg har kopieret ind... skal jeg det?

Koden fra kabbak virker fint som den plejer, det er din Excel du skal sætte op.

2003, så skal huskeren jo noget på arbejde, men mener det er noget lignende...

Tools -> Macro -> Security
Fanen "Trusted Publishers"
Sæt V ved "Trust access to Visual Basic Project"

Hmm.. Det køre ikke helt for mig.

Ved at gøre som Smartoffice siger har jeg fået koden til at virke.
Men når jeg så prøve at indsætte min egen kode går det helt galt. Jeg har omskrevet koden til dette her:

Public Sub Flytmakro()
    Windows("Bestilling.xls").Activate
    Code = "Sub Worksheet_SelectionChange(ByVal Target As Range)" & vbCrLf
    Code = Code & "    Sheets("Søndag").select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Mandag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Tirsdag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Onsdag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Torsdag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Fredag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Lørdag").Select
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:=" <> ""
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True"
    Code = Code & "    Selection.AutoFilter Field:=1"
    Code = Code & "    Sheets("Bestillinger").Select
    Code = Code & " End Sub"

    With ActiveWorkbook.VBProject. _
        VBComponents(ActiveSheet.Name).CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With
End Sub

Men alle de linie hvor der står en uge dag i bliver markeret med rød og den brokker sig.
Jeg har også prøvet at fjerne de linie og så køre makroen, men så stopper den samme sted som jeg fik den til at stoppe i starten.

Hvad gøre jeg glat?

du skal huske
& vbCrLf
efter hver linje

prøv med
den sætter koden ind i ThisWorkbook modulet

Public Sub Flytmakro()
    Dim Code, NextLine As Integer, SH As Variant
    Windows("Bestilling.xls").Activate
    Code = "Sub FilterOgUdskriv" & vbCrLf
    Code = Code & "    Dim SH As Variant, I as integer" & vbCrLf
    Code = Code & "    SH = Array(""Søndag"", ""Mandag"", ""Tirsdag"", ""Onsdag"", ""Torsdag"", ""Fredag"", ""Lørdag"")" & vbCrLf
    Code = Code & "    For I = 0 To UBound(SH)" & vbCrLf
    Code = Code & "    Sheets(SH(i)).select" & vbCrLf
    Code = Code & "    Range(""A1:I1"").Select" & vbCrLf
    Code = Code & "    Selection.AutoFilter" & vbCrLf
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:= ""<>""" & vbCrLf
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True" & vbCrLf
    Code = Code & "    Selection.AutoFilter" & vbCrLf
    Code = Code & "    Next" & vbCrLf
    Code = Code & "    Sheets(""Bestillinger"").Select" & vbCrLf
    Code = Code & " End Sub" & vbCrLf

    With ActiveWorkbook.VBProject. _
        VBComponents("ThisWorkbook").CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With
End Sub

Jubii nu virker det..

Og så lige 2 tillægsspørgsmål.

Jeg har lavet denne makro til at kopiere en knap over fra et andet ark og tiløje den makro som er blevet flyttet. Men når jeg køre den vil den havde at makro høre til det andet ark og så kan den ikke finde den. Det skal være sådan at det fungere altid også selvom brugerne vælger at kalde arket noget andet. Har du en hurtigt løsning til dette?
Makron jeg har lavet ser sådan her ud:

Sub Kopierknap()
    Windows("Udpak slettes.xls").Activate
    Sheets("Print").Select
    ActiveSheet.Shapes("Button 10").Select
    Selection.Copy
    Windows("Bestilling.xls").Activate
    Range("B6").Select
    ActiveSheet.Paste
    Selection.OnAction = "FilterOgUdskriv"
End Sub

Og sidste spørgsmål hvordan lukker jeg dette spørgsmål og giver point for svaret? Kan ikke lige gennemskue det.

Jeg har prøvet at koge det sammen til en makro, det laver et modul, det er der makroer normalt er.
Du skal lige tilføje en reference, for at det virker.

Public Sub Flytmakro()
    Dim Code, NextLine As Integer, SH As Variant, ModulNavn As String, MinWorkbook As String

    ModulNavn = "MitModul"    ' ret til det navn du vil bruge
    MinWorkbook = "Bestilling.xls" ' ret til det navn du vil bruge
    ' fundet på nettet, det kan lave et modul
    Dim VBP As VBProject
    Dim VBC As VBComponent
    Dim VBMod As CodeModule

    ' -----------------------------------------------------------
    ' Coded by Shasur for http://vbadud.blogspot.com
    'This program will need reference to Microsoft Visual Basic for Extensibility Library
    ' gøres i Tools References, fin det og sæt flueben i firkanten, tryk så OK
    ' -----------------------------------------------------------
    Windows(MinWorkbook).Activate
    Set VBP = ActiveWorkbook.VBProject
    Set VBC = VBP.VBComponents.Add(vbext_ct_StdModule)
    VBC.Name = ModulNavn
    ' slut med det fra nettet

    Code = "Sub FilterOgUdskriv" & vbCrLf
    Code = Code & "    Dim SH As Variant, I as integer" & vbCrLf
    Code = Code & "    SH = Array(""Søndag"", ""Mandag"", ""Tirsdag"", ""Onsdag"", ""Torsdag"", ""Fredag"", ""Lørdag"")" & vbCrLf
    Code = Code & "    For I = 0 To UBound(SH)" & vbCrLf
    Code = Code & "    Sheets(SH(i)).select" & vbCrLf
    Code = Code & "    Range(""A1:I1"").Select" & vbCrLf
    Code = Code & "    Selection.AutoFilter" & vbCrLf
    Code = Code & "    Selection.AutoFilter Field:=1, Criteria1:= ""<>""" & vbCrLf
    Code = Code & "    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True" & vbCrLf
    Code = Code & "    Selection.AutoFilter" & vbCrLf
    Code = Code & "    Next" & vbCrLf
    Code = Code & "    Sheets(""Bestillinger"").Select" & vbCrLf
    Code = Code & " End Sub" & vbCrLf

    With ActiveWorkbook.VBProject. _
        VBComponents(ModulNavn).CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With

    ' laver knap og tilknytter makro
    ' [B6].Left er det samme som Range("B6").Left
    Sheets("Print").Activate
    ActiveSheet.Buttons.Add([B6].Left, [B6].Top, [B6].Width, [B6].Height).Select
    Selection.Characters.Text = "Udskriv"
    Selection.OnAction = MinWorkbook & "!FilterOgUdskriv"

End Sub