Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1124to1128
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Spalte durchsuchen

Spalte durchsuchen
Ralf
Hallo
Mal ne frage und zwar habe ich gestern ein Makro aus dem Forum erstellt bekommen der klappt auch super zur Erklärung
der bewirkt das vor dem Drucken die zelle G ausgeblendet wird wenn in F nicht SW steht
jetzt meine Frage kann man das Makro auch so gestalten, das wenn gar kein SW in F vorhanden ist das die komplette Spalte G vor dem Drucken ausgeblendet wird und nach dem Drucken wieder eingeblendet wird
Hoffe ich habe es halbwegs gut erklärt
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Bleib bitte im alten Thread o.w.T.
07.01.2010 18:19:52
Reinhard


AW: Bleib bitte im alten Thread o.w.T.
07.01.2010 18:22:33
Ralf
sorry aber das ist doch jetzt schon wieder etwas anderes nur halt mit dem makro das ich bekommen habe
AW: Spalte durchsuchen
07.01.2010 18:42:05
Tino
Hallo,
habe zwar mit einer Rückmeldung auf die zweite Frage im letzten Beitrag gerechnet
aber da ist nichts gekommen.
Auch ich freue mich über positive Rückmeldungen auch wenn die Frage für Dich erledigt ist.
Hier die gewünschte Anpassung, sollte funzen.
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 booIsSW As Boolean 
 
Application.ScreenUpdating = False 
 
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 Application.WorksheetFunction.CountIf(.Range("G16:G120"), "SW") = 0 Then 
             booIsSW = True 
             Exit For 
            End If 
            If meArFG(A, 1) <> "SW" Then 
                meArG(A, 1) = "" 
            End If 
        Next A 
        If booIsSW Then 
            .Columns(7).Hidden = True 
            booIsSW = False 
        Else 
            .Range("G16").Resize(Ubound(meArG)) = meArG 
        End If 
    End With 
Next i 
Application.ScreenUpdating = True 
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 
        Application.ScreenUpdating = False 
        For i = 1 To 12 
            With Sheets(MonthName(i, True)) 'Tabelle Jan bis Dez 
             If .Columns(7).Hidden Then 
                .Columns(7).Hidden = False 
             Else 
                .Range("G16").Resize(Ubound(MerkAr(i))) = MerkAr(i) 
             End If 
            End With 
        Next i 
        Erase MerkAr 
        Application.ScreenUpdating = True 
    End If 
 
End Sub 
 
 
 
 
Danke schon mal für die Rückmeldung. ;-)
Gruß Tino
Anzeige
mir ist noch ein kleiner Fehler aufgefallen
07.01.2010 19:04:00
Tino
Hallo,
so ist es besser, damit die separate Sub nicht so durchläuft oder gestartet werden kann.
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 booIsSW As Boolean 
 
Application.ScreenUpdating = False 
Redim Preserve MerkAr(1 To 12) 
 
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 Application.WorksheetFunction.CountIf(.Range("G16:G120"), "SW") = 0 Then 
             booIsSW = True 
             Exit For 
            End If 
            If meArFG(A, 1) <> "SW" Then 
                meArG(A, 1) = "" 
            End If 
        Next A 
        If booIsSW Then 
            .Columns(7).Hidden = True 
            booIsSW = False 
        Else 
            .Range("G16").Resize(Ubound(meArG)) = meArG 
        End If 
    End With 
Next i 
Application.ScreenUpdating = True 
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 
     
    GetSafeArrayPointer MerkAr, sfaPtr 
 
    If sfaPtr > 0 Then 
        Application.ScreenUpdating = False 
        For i = 1 To 12 
            With Sheets(MonthName(i, True)) 'Tabelle Jan bis Dez 
             If .Columns(7).Hidden Then 
                .Columns(7).Hidden = False 
             Else 
                .Range("G16").Resize(Ubound(MerkAr(i))) = MerkAr(i) 
             End If 
            End With 
        Next i 
        Erase MerkAr 
        Application.ScreenUpdating = True 
    End If 
 
End Sub 
 
 
 
 
Gruß Tino
Anzeige
Sorry habe aber erst heute wieder eingeschaltet
09.01.2010 12:35:30
Ralf
Hallo Tino
Sorry das ich mich nicht mehr gemeldet habe aber
ich habe den PC gerade erst wieder eingeschaltet da ich noch los musste und es jetzt erst wieder geschafft habe mich vor dem PC zu setzen hoffe das ist OK
dein Makro funktiuoniert super Danke echt gute arbeit
Mit besten Grüßen aus Damme
danke für die positive Rückmeldung oT.
09.01.2010 12:44:23
Tino

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige