Office: Makro geht nicht so wie es soll

Blacky1980 · 27. August 2012

Hallo an alle hier im Forum.

Ich habe ein Marko teilweise voneinem andernen und Teilweise aufgezeichnet zusammen gebaut. Soweit geht auch alles!

Mein problem ist nun das ich dieses Makro von einer anderen Tabellenblatt ausführen möchte als da wo es was machen soll.

Z.B Das Marko wird in "Abfragekartei" über eine Button aufgerufen und soll in "Maschinen Liste" fast alles kopieren und aus bestimmten Zellen den Inhalte löschen und dann eine bestimmten Mappe öffnen und dort das kopierte einfügen. Wobei es vorgaben für die mappe gibt. Name der Mappe ist "Inventur.xlsm".

Es sollen die Spalten A-E komplett und Spalte F-G nur die erste Zeile kopiert werden. Die Inhale in den Zeilen F2-G....... soll nur der Zelleninhalt gelöscht werden. Zeile 1 ist ein Drucktitel der soll auch mit in die andere Mappe übernommen werden.

So wie ich das jetzt habe braucht das Marko sehr lange und kann nur vom selben Tabellenballt ausgeführt werden.

Ich habe mal das jetzige Makro mit angehängt.

Code:

Sub InventurVorbereitung()
    Dim wks As Worksheet
    Dim wks1 As Worksheet
    Dim wkb As Workbook
    Dim vInv As Variant

Application.ScreenUpdating = False
    Set wks = ThisWorkbook.Worksheets("Maschinen Liste")
    MsgBox "Jetzt erst Inventurdatei öffnen"
    vInv = Application.GetOpenFilename("Microsoft Excel-Dateien (*.xlsm),*.xlsm")
    If vInv <> False Then
        Workbooks.Open (vInv)
        Set wkb = ActiveWorkbook
        wks.Copy wkb.Worksheets(Worksheets.Count)
        Set wks1 = ActiveWorkbook.ActiveSheet
    Else
        MsgBox "Inventurdatei nicht ausgewählt"
        Exit Sub
    End If
    ActiveSheet.Unprotect pw
        wks1.Range("G5:G" & Cells(Rows.Count, 7).End(xlUp).Row).ClearContents
        wks1.Columns("F:G").ClearContents
        wks1.Columns("H:L").Delete


    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$G$87"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.984251968503937)
        .RightMargin = Application.InchesToPoints(0.984251968503937)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 59
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
        Rows("1:1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$G$87"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.984251968503937)
        .RightMargin = Application.InchesToPoints(0.984251968503937)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 59
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Range("A1:G1").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("Tabelle1[[#Headers],[Spalte1]]").Select
    ActiveCell.FormulaR1C1 = "Maschinen Stellplatz"
    With ActiveCell.Characters(Start:=1, Length:=19).Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("Tabelle1[[#Headers],[Spalte2]]").Select
    ActiveCell.FormulaR1C1 = "Zubehöre Lagerplatz"
    With ActiveCell.Characters(Start:=1, Length:=18).Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

Application.ScreenUpdating = True

ActiveSheet.Protect pw
    End Sub

Ich hoffe Ihr versteht was ich machen möchte und was ich vor habe.

Gruß Michael

miriki · 6. September 2012

Zitat von Blacky1980: ↑

Mein problem ist nun das ich dieses Makro von einer anderen Tabellenblatt ausführen möchte als da wo es was machen soll.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Um eine Prozedur / Funktion "von überall her" aufrufen zu können, darf sie nicht im Source eines Tabellenblatts stehen, sondern muß in einem "globalen" Modul stehen.

Der Rest, der dann noch anzupassen ist, sind in erster Linie die Referenzen auf die zu bearbeitenden Blätter und / oder Mappen. Hier bietet sich die Verwendung von durch SET gesetzten Referenzen im Kopf der Routine an, was auf den ersten Blick in Deinem Source ja schon passiert.

Elegant wird die Sache, wenn die globale Routine mit Parametern angesteuert wird, in denen z.B. die Blattnamen für die Operation übergeben werden.

Was vorsichtshalber vermieden werden sollte: Verwendung von ActiveSheet, da die Routine ja jederzeit aufgerufen werden kann und deswegen nicht sicher ist, welches denn gerade das aktive Blatt ist. (siehe oben: SET benutzen!)

Wichtig letztendlich, was Du ja aber auch schon angesprochen hast: Der Aufruf der Routine braucht eine Initialzündung, die dann z.B. durch Buttons auf den jeweiligen Blättern realisiert werden kann. Der Buttonklick macht dann nichts weiter, als eben diese globale Routine aufzurufen - der klassche Einzeiler. ;-)

Gruß, Michael

miriki · 6. September 2012

Zitat von miriki: ↑

Um eine Prozedur / Funktion "von überall her" aufrufen zu können, darf sie nicht im Source eines Tabellenblatts stehen, sondern muß in einem "globalen" Modul stehen.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Um das etwas zu verdeutlichen, habe ich mal ein kleines Beispiel zusammengebastelt:

Stell Dir vor, Du hast 3 Blätter in einer Mappe. Auf jedem Blatt ist ein Button, der etwas tun soll. Das ist zwar prinzipiell immer das gleiche, variiert aber geringfügig auf den Blättern. Im Beispiel-Modell macht der Button folgendes:
Auf dem ersten Blatt wird durch den Button ein Bereich in "rot" eingefärbt. Der gleiche Bereich auf den anderen Blättern wird ebenfalls in "rot" eingefärbt.
Auf dem zweiten Blatt passiert im Prinzip das gleiche mit dem Einfärben, nur daß die Bereiche hier in "grün" eingefärbt werden.
Und, rate mal... Auf dem dritten Blatt wird eine Einfärbung in "blau" durchgeführt.

Die Routine "Einfaerbung" wird in ein globales Modul verpackt und erwartet 2 Parameter: a) Den Namen des Blatts und b) die Farbe:
Code:
Option Explicit

Public Sub Einfaerbung(strWorksheet$, lngFarbe&)

    Dim wksWorksheet As Worksheet
    Dim rngRange As Range

    Set wksWorksheet = Worksheets(strWorksheet)
    Set rngRange = wksWorksheet.Range("d2:e3")

    rngRange.Interior.Color = lngFarbe
    rngRange.BorderAround LineStyle:=xlContinuous, Weight:=xlThick, Color:=RGB(0, 0, 0)

End Sub
Und dazu passend jetzt die Routine des Buttonklicks aus dem ersten Tabellenblatt:
Code:
Option Explicit

Private Sub B_Einfaerbung_Click()

    Einfaerbung ActiveSheet.Name, RGB(255, 0, 0)
    Einfaerbung "Tabelle2", RGB(255, 0, 0)
    Einfaerbung "Tabelle3", RGB(255, 0, 0)

End Sub
Was sagte ich noch? Man sollte "ActiveSheet" vermeiden? Ja, stimmt, aber das bezog sich auf das globale Modul. Hier befinden wir uns im Blatt-Source, der genau weiß, welches gerade das aktive Blatt ist.

Die Codes in den Blättern 2 und 3 sind dann sehr ähnlich:
Code:
Option Explicit

Private Sub B_Einfaerbung_Click()

    Einfaerbung "Tabelle1", RGB(0, 255, 0)
    Einfaerbung ActiveSheet.Name, RGB(0, 255, 0)
    Einfaerbung "Tabelle3", RGB(0, 255, 0)

End Sub
Code:
Option Explicit

Private Sub B_Einfaerbung_Click()

    Einfaerbung "Tabelle1", RGB(0, 0, 255)
    Einfaerbung "Tabelle2", RGB(0, 0, 255)
    Einfaerbung ActiveSheet.Name, RGB(0, 0, 255)

End Sub
Und dann kann man noch prima zum Aufräumen in das Arbeitsmappen-globale Modul eine Routine packen, die beim Öffnen der Mappe automatisch aufgerufen wird:
Code:
Option Explicit

Private Sub Workbook_Open()

    Einfaerbung "Tabelle1", RGB(255, 255, 255)
    Einfaerbung "Tabelle2", RGB(255, 255, 255)
    Einfaerbung "Tabelle3", RGB(255, 255, 255)

End Sub
Mit diesem Konstrukt müßte es Dir eigentlich klar werden, wie Du mit lokalen und globalen Routinen handwerken kannst. Entscheidend ist eben, daß die Routine "Einfaerbung" von allen anderen Stellen innerhalb der Mappe aus aufgerufen werden kann. Die Routinen "B_Einfaerbung_Klick" sind aber nur in den einzelnen Modulen der Blätter "lokal" verfügbar. Nur deswegen ist es auch möglich, mehrmals den gleichen Namen zu benutzen. Wären die Routinen "global" verfügbar, würde es Stress mit dopperlter Namensvergabe geben.

Gruß, Michael

Blacky1980 · 9. September 2012

Danek für die Antwort aber leider kann ich da nicht viel mit anfagen.

Um es einfacher zusagen:

Es soll von allen Blättern aus möglich sein die Unsichtbaer Tabelle "Maschinen Liste" in eine andere Mappe kopiert werden. Wobei zu vor die Mappe "Inventuer.xlsm" gesucht werden soll. Dann sollem nur die Spalten A-E komplett kopiert werden und von Spalte F-G nur die erste Zeille kopiert werden. Die erste Zeile ist ein Drucktitel ist auch Fixiert und hatt eine Tabbelenformtierung drin die soll auch mit.

Was ich auch gerne hätte wäre das der Tabellen Namen mit Name und Datum geschrieben wird. Bsp. "Inventur vom 09.09.2012"

Ich habe auch mal die beiden Datein beigfügt als zip-Datei. Die Test-Datei ist nur eine Tabelle mit der Liste drin. Die Inventur sollte leer sein aber wenn nicht ist das nicht schlimm. Das Passwort ist "test".

Ich sage schonmal Danke für die Hilfe.

Gruß Michael

Ich hatte noch vergessen zu sagen das sich in der Orginal Tabelle in den Zellen nur Fromel befinden die sollen natürlich mit dem Ergeniss ersetzt werden und die Zelleninhalte der Spalten F2-F... und G2-G... sollen geleert werden aber nich die Formatierung die soll so bleiben. Das habe ich gerade erst gesehen da ich noch weiter an der mappe arbeite.

miriki · 10. September 2012

Zitat von Blacky1980: ↑

Danek für die Antwort aber leider kann ich da nicht viel mit anfagen.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dann hast Du Dich noch nicht genug damit auseinander gesetzt... ;-)

Es soll von allen Blättern aus möglich sein die Unsichtbaer Tabelle "Maschinen Liste" in eine andere Mappe kopiert werden.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ein Button "B_Kopieren" in jedem Blatt, von dem aus es möglich sein soll, wäre der erste Schritt. Die (jeweils lokale) Routine B_Kopieren_Click() kann dann die in Modul1 angelegte, globale Routine Kopieren() aufrufen.

Wobei zu vor die Mappe "Inventuer.xlsm" gesucht werden soll. Dann sollem nur die Spalten [...]
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Was Du im Einzelnen kopierst, löschst, verschiebst, neu anlegst und speicherst kannst Du völlig frei in der Kopieren() Routine festlegen.

Da würde ich Dir empfehlen, das ganze Geraffel mal mit dem Makro-Rekorder aufzuzeichnen und dann nach entsprechendem Abspecken (der Rekorder erzeugt grauslichen Code) in die Kopieren() Routine einzubinden und anzupassen.

Ich bin noch nicht so ganz durch Deine Beschreibung durchgestiegen (eindeutig zu früh am Morgen...), aber es klingt ein wenig für mich so, als wenn eine "Vorlage" für Dich ein guter Ansatz wäre. Also ein quasi leeres Blatt mit entsprechender Formatierung, Seiteneinrichtung, Überschriften, Fixierung usw. Dieses Blatt kopierst Du dann und ergänzt es mit den aktuellen Werten aus einem anderen Blatt.

Btw: Formel-Ergebnisse durch konstante Werte ersetzen:
Code:
range1.copy
range2.pastespecial paste:=xlpastevalues
Löschen:
Code:
range1.clearformats 'nur formate, inhalte bleiben erhalten
range1.clearcontents 'nur inhalte, formate bleiben erhalten
range1.clear 'inhalte und formate
Gruß, Michael

Blacky1980 · 10. September 2012

Hallo Michael

Ich habe es versucht auf zu zeichnen nur leider klappt das alles nicht so wie es soll das ander ist das es sehr Langsam ist. Das nächste ist das die Formeln so drin bleiben und dadurch immer nur fehler kommen.

Ok ich versuche es nochmal zu Beschreiben:

Ich habe eine Mappe mit mehreren Tabllen die Tabelle mit dem Namen "Maschinen Liste" soll in einer andere Mappe kopiert werden wobei erst ein Passwort für das Makro eigegeben werden muss und dann die Mappe gesucht bzw. Ausgewählt werden muß. Wenn das gemacht ist soll die Tabelle kopiert werden wobei die Gesamte Formatierung bleiben soll (Fixierung, Drucktitel, Füllfarbe usw.). Die Formeln soll natürlich nicht mit sondern nur die Ausgabe bzw. das Ergebniss der Formeln. Dann soll der Zelleninhalt der Zellen "F2 bis F1000" und "G2 bis G1000" gelöscht werden.

Dann ist da noch etwas die Tabelle ist Ausgeblendet.

So wie mein Code jetzt ist macht es das fast alles genau so wie das möchte nur sehr sehr Langsam. Das mit dem Datum bekomme ich nicht hin das im Register unten das Datum mit dazu macht. Bsp. "Maschinen Liste Stand: 10.09.2012" oder "Maschinen Invetur 10.09.2012" so sollte es dann unten stehen.

Hier nochmal mein Code:

Code:

Private Sub CommandButton12_Click()


Dim strPW As String
Dim strEingabe As String
strPW = "21032006"
strEingabe = InputBox("Diese Funktion ist nur für den Lagerrist vorgesehen. Bitte identifizieren Sie sich mit der Eingabe des Passwortes:", "Passwort - Abfrage")
If strPW <> strEingabe Then
MsgBox "Der Vorgang wurde abgebrochen. Das Passwort wurde falsch eingegeben", vbExclamation
    GoTo pntEnde
Else

Sheets("Abfragekarte").Select
    Sheets("Maschinen Liste").Visible = True
    Sheets("Maschinen Liste").Select

    
    
    Dim wks As Worksheet
    Dim wks1 As Worksheet
    Dim wkb As Workbook
    Dim vInv As Variant

Application.ScreenUpdating = False
    Set wks = ThisWorkbook.Worksheets("Maschinen Liste")
    MsgBox "Jetzt erst Inventurdatei öffnen"
    vInv = Application.GetOpenFilename("Microsoft Excel-Dateien (*.xlsm),*.xlsm")
    If vInv <> False Then
        Workbooks.Open (vInv)
        Set wkb = ActiveWorkbook
        wks.Copy wkb.Worksheets(Worksheets.Count)
        Set wks1 = ActiveWorkbook.ActiveSheet
    Else
        MsgBox "Inventurdatei nicht ausgewählt"
        Exit Sub
    End If
    ActiveSheet.Unprotect pw
        wks1.Range("G5:G" & Cells(Rows.Count, 7).End(xlUp).Row).ClearContents
        wks1.Columns("F:G").ClearContents


    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$G$87"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.984251968503937)
        .RightMargin = Application.InchesToPoints(0.984251968503937)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 59
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
        Rows("1:1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$G$87"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.984251968503937)
        .RightMargin = Application.InchesToPoints(0.984251968503937)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 59
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Range("A1:G1").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("Tabelle1[[#Headers],[Spalte1]]").Select
    ActiveCell.FormulaR1C1 = "Maschinen Stellplatz"
    With ActiveCell.Characters(Start:=1, Length:=19).Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("Tabelle1[[#Headers],[Spalte2]]").Select
    ActiveCell.FormulaR1C1 = "Zubehöre Lagerplatz"
    With ActiveCell.Characters(Start:=1, Length:=18).Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

Application.ScreenUpdating = True

ActiveSheet.Protect pw


    

End If
    Windows("Maschienen Verwaltung.xls").Activate
    Sheets("Abfragekarte").Select
    Range("B4:F5").Select
    Sheets("Maschinen Liste").Visible = False
    Windows("Inventur.xlsm").Activate
pntEnde:
Unload Me
End Sub

Wie und was ich da nun rauslöschen kann weiss ich leider überhauptnicht. Ich habe es auch teilweise schon versucht nur dann kommt ein fehler nach dem anderen.

Das andere Problem was ich da auch habe ist das beim Kopieren die Seitenumbrüche nicht mit übernimmt was er aber machen sollte. Immer 45 Zeilen pro Blatt + Drucktitel.

Ich kenne mich auch noch nicht so gut mit Makro und VBA aus. Ich blick da eh nicht mehr durch. Ich habe mir das alles etwas leichter und einfacher vorgestellt. Werde das ganze Ding wohl oder übel an den Nagelhägen müssen. Ich hatte ja gehofft das ich eine fertige Lösung dazu finde!

Vielen Dank noch mal für die Hilfe.

Gruß Michael

miriki · 11. September 2012

Zitat von Blacky1980: ↑

das ander ist das es sehr Langsam ist.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dafür hab ich eine Erklärung: Die Zugriffe auf das PageSetup bremsen den Kram höllisch aus. Das kenne ich aus leidlicher Erfahrung beim Anlegen neuer Blätter, denen ich dann Seitenränder, Ausrichtung, Kopf- und Fußzeile usw. verpasse, um das "corporate design" hinzubekommen. Deswegen schrieb ich ja, daß es sinnvoll sein könnte, eine formatierte Vorlage zu benutzen, deren Kopie dann mit Daten gefüllt wird.

Das nächste ist das die Formeln so drin bleiben
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ich schrieb auch, wie die Formeln durch konstante Werte ersetzt werden können... (Stichwort copy, pastespecial)

die Tabelle mit dem Namen "Maschinen Liste" soll in einer andere Mappe kopiert werden [...] Die Formeln soll natürlich nicht mit sondern nur die Ausgabe bzw. das Ergebniss der Formeln.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.
Code:
(1)
wb[COLOR=#ff0000][B]1[/B][/COLOR].worksheets("maschinen liste").copy
wb[COLOR=#ff0000][B]2[/B][/COLOR].worksheets("maschinen liste").cells copy : wb[COLOR=#ff0000][B]2[/B][/COLOR].cells.pastespecial paste:=xlpastevalues
Dann soll der Zelleninhalt der Zellen "F2 bis F1000" und "G2 bis G1000" gelöscht werden.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.
Code:
(2)
wb[COLOR=#ff0000][B]2[/B][/COLOR].worksheets("maschinen liste").range("f2:g1000").clearcontents
Dann ist da noch etwas die Tabelle ist Ausgeblendet.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.
Code:
worksheets("maschinen liste").visible = true 'und wieder "false" zum ausblenden
Das mit dem Datum bekomme ich nicht hin das im Register unten das Datum mit dazu macht. Bsp. "Maschinen Liste Stand: 10.09.2012" oder "Maschinen Invetur 10.09.2012" so sollte es dann unten stehen.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dazu kannst Du das aktuelle Datum mit der now() Funktion in eine Formatierung mittels der format$() Funktion schicken:
Code:
jetzt = format$(now(),"DD.MM.YYYY hh:nn:ss") '--> 01.02.2003 04:05:06
Das kannst Du dann zusammenknoten mit welcher Beschriftung auch immer drumherum. Z.B.:
Code:
beschriftung = "Maschinen Liste Stand " & jetzt
Code:
        wks.Copy wkb.Worksheets(Worksheets.Count)
        Set wks1 = ActiveWorkbook.ActiveSheet
        ' --> (1) siehe oben
Code:
    ActiveSheet.Unprotect pw
        'wks1.Range("G5:G" & Cells(Rows.Count, 7).End(xlUp).Row).ClearContents
        'wks1.Columns("F:G").ClearContents
        ' --> (2) siehe oben
Code:
    With ActiveSheet.PageSetup
        [ ... ]
Über'n groben Daumen 90 Zugriffe auf das PageSetup - Das ist absoluter Overkill. Wie lange wartest Du dabei? 1, 2 Minuten?

Ich hatte ja gehofft das ich eine fertige Lösung dazu finde!
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

In einem Forum findest Du in erster Linie Hilfe zur Selbsthilfe. Für Auftragsarbeiten, um fertige Lösungen zu erhalten, wären die gelben Seitenb besser geeignet. ;-)

Gruß, Michael

Blacky1980 · 14. September 2012

Hallo Michael

Ich habe das versucht und es kommen immer nur fehler. Werde das nun lassen ich blicke da hinten und vorne nicht mehr durch. Ich werde mich etwas mehr damit befassen bis ich es dan wieder versuche.

Danke aber für die Hilfe.

Office: Makro geht nicht so wie es soll

Makro geht nicht so wie es soll

Anhänge:

Einfärbung.xls (38,5 KB)

Makro geht nicht so wie es soll

Anhänge:

testdateien.zip (32 KB)

Makro geht nicht so wie es soll

Makro geht nicht so wie es soll

Makro geht nicht so wie es soll - Similar Threads - Makro

Name der Datei durch Excel geändert

Ein Makro für mehrere Register

Makro öffnet unerwartete Datei

Leerzeilen entfernen

Makro Schaltflaechen vervielfaeltigen sich....

Seit Win 11 Zugriffsprobleme bei Excel über Makros

VBA-Makro zur Zellenformatierung Syntax probleme