Microsoft Excel

Herbers Excel/VBA-Archiv

before print | Herbers Excel-Forum


Betrifft: before print von: Ralf
Geschrieben am: 06.01.2010 17:52:13

Hallo
kann man ein makro so erstellen ?
das es vor dem Drucken alle Zellen in G leert wenn nicht in F SW steht und nach dem Drucken soll es wieder rückgängig gemacht werden
Und das in dem zeilen 16 - 120

und wenn das geht dann noch am besten über eine Schaltfläche :-)

gruß

  

Betrifft: AW: before print von: Hajo_Zi
Geschrieben am: 06.01.2010 18:16:51

Hallo Ralf,

versuche es mal mit folgendem Makro, ungetestet.

Option Explicit

Sub Makro1()
    Range("G6:G120").NumberFormat = ";;;"
    ActiveSheet.PrintOut
    Range("G6:G120").NumberFormat = "General"
End Sub
GrußformelHomepage


  

Betrifft: AW: before print von: Tino
Geschrieben am: 06.01.2010 18:19:06

Hallo,
könnte z. Bsp. so funktionieren.

Tabelle im Code noch anpassen.

kommt als Code in DieseArbeitsmappe

Option Explicit 
 
Private Sub Workbook_BeforePrint(Cancel As Boolean) 
Dim A& 
Dim meArG(), meArFG() 
 
With Sheets("Tabelle1") 'Tabelle anpassen 
    MerkAr = .Range("G16:G120").Value2 
    meArFG = .Range("G16:F120").Value2 
     
    meArG = MerkAr 
     
    For A = 1 To Ubound(meArFG) 
        If meArFG(A, 1) <> "SW" Then 
            meArG(A, 1) = "" 
        End If 
    Next A 
 
    .Range("G16").Resize(Ubound(meArG)) = meArG 
End With 
 
Application.OnTime Now + TimeSerial(0, 0, 1), "NachPrint" 
 
End Sub 
 
kommt als Code in Modul1
Option Explicit 
Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias _
                    "GetMem4" (pArray() As Any, sfaPtr As Long) 
Public MerkAr() 
 
Sub NachPrint() 
Dim sfaPtr As Long 
GetSafeArrayPointer MerkAr, sfaPtr 
If sfaPtr > 0 Then 
    'Tabelle anpassen 
    Sheets("Tabelle1").Range("G16").Resize(Ubound(MerkAr)) = MerkAr 
    Erase MerkAr 
End If 
End Sub 
Gruß Tino


  

Betrifft: AW: before print von: Ralf
Geschrieben am: 06.01.2010 18:30:04

donner gehst Du ab :-)

Danke das hat mir sehr geholfen jetzt noch nje frage ich habe mehrere tabellenblätter wo ich das brauche
kann man den bereich Tabelle anpassen so gestalten das das makro auf mehrere tabellen in der Arbeitzmappe funktioniert ?

also ich habe tabellenblätter jan feb mär apr ...... bis dez


  

Betrifft: kannst ja mal testen, von: Tino
Geschrieben am: 06.01.2010 19:29:44

Hallo,
die Tabellen
Jan, Feb, Mrz, Apr, Mai, Jun, Jul,Aug ,Sep ,Okt ,Nov u. Dez
müssen vorhanden sein es gibt keine Fehlerüberprüfung.

kommt als Code in DieseArbeitsmappe

Option Explicit 
 
Private Sub Workbook_BeforePrint(Cancel As Boolean) 
Dim A& 
Dim meArG(), meArFG() 
Dim i As Integer, sMonat$ 
 
For i = 1 To 12 
  
    With Sheets(MonthName(i, True)) 'Tabelle Jan bis Dez 
 
        MerkAr(i) = .Range("G16:G120").Value2 
        meArFG = .Range("G16:F120").Value2 
         
        meArG = MerkAr(i) 
         
        For A = 1 To Ubound(meArFG) 
            If meArFG(A, 1) <> "SW" Then 
                meArG(A, 1) = "" 
            End If 
        Next A 
     
        .Range("G16").Resize(Ubound(meArG)) = meArG 
    End With 
Next i 
Application.OnTime Now + TimeSerial(0, 0, 1), "NachPrint" 
 
End Sub 
 
kommt als Code in Modul1
Option Explicit 
Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias _
                    "GetMem4" (pArray() As Any, sfaPtr As Long) 
Public MerkAr(1 To 12) 
 
Sub NachPrint() 
Dim sfaPtr As Long 
Dim i As Integer 
 
GetSafeArrayPointer MerkAr, sfaPtr 
 
If sfaPtr > 0 Then 
  For i = 1 To 12 
    With Sheets(MonthName(i, True)) 'Tabelle Jan bis Dez 
    .Range("G16").Resize(Ubound(MerkAr(i))) = MerkAr(i) 
    End With 
  Next i 
  Erase MerkAr 
End If 
End Sub 
Gruß Tino


  

Betrifft: Korrektur wegen Tabellennamen von: Tino
Geschrieben am: 06.01.2010 19:45:45

Hallo,
weil Deine Monate nicht wie von mir angegeben benannt sind
hier die Version wo Du die Tabellennamen angeben kannst.

kommt als Code in DieseArbeitsmappe

Option Explicit 
 
Private Sub Workbook_BeforePrint(Cancel As Boolean) 
Dim A& 
Dim meArG(), meArFG() 
Dim i As Integer, sMonat$ 
Dim meArTabellen 
 
'Tabellennamen eintragen 
meArTabellen = Array("jan", "feb", "mär", "apr", "mai", "jun", "jul", "aug", "sep", "okt", "nov", "dez") 
Redim Preserve MerkAr(0 To 11) 
For i = Lbound(meArTabellen) To Ubound(meArTabellen) 
  
    With Sheets(meArTabellen(i)) 'Tabelle Jan bis Dez 
 
        MerkAr(i) = .Range("G16:G120").Value2 
        meArFG = .Range("G16:F120").Value2 
         
        meArG = MerkAr(i) 
         
        For A = 1 To Ubound(meArFG) 
            If meArFG(A, 1) <> "SW" Then 
                meArG(A, 1) = "" 
            End If 
        Next A 
     
        .Range("G16").Resize(Ubound(meArG)) = meArG 
    End With 
Next i 
Application.OnTime Now + TimeSerial(0, 0, 1), "NachPrint" 
 
End Sub 
 
kommt als Code in Modul1
Option Explicit 
Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias _
                    "GetMem4" (pArray() As Any, sfaPtr As Long) 
 
Public MerkAr() 
 
Sub NachPrint() 
Dim sfaPtr As Long 
Dim i As Integer 
Dim meArTabellen 
 
GetSafeArrayPointer MerkAr, sfaPtr 
 
If sfaPtr > 0 Then 
    'Tabellennamen eintragen 
    meArTabellen = Array("jan", "feb", "mär", "apr", "mai", "jun", "jul", "aug", "sep", "okt", "nov", "dez") 
    For i = Lbound(meArTabellen) To Ubound(meArTabellen) 
      With Sheets(meArTabellen(i)) 'Tabelle Jan bis Dez 
      .Range("G16").Resize(Ubound(MerkAr(i))) = MerkAr(i) 
      End With 
    Next i 
    Erase MerkAr 
End If 
 
End Sub 
Gruß Tino