Microsoft Excel

Herbers Excel/VBA-Archiv

Spalte durchsuchen | Herbers Excel-Forum


Betrifft: Spalte durchsuchen von: Ralf
Geschrieben am: 07.01.2010 17:58:23

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

  

Betrifft: Bleib bitte im alten Thread o.w.T. von: Reinhard
Geschrieben am: 07.01.2010 18:19:52




  

Betrifft: AW: Bleib bitte im alten Thread o.w.T. von: Ralf
Geschrieben am: 07.01.2010 18:22:33

sorry aber das ist doch jetzt schon wieder etwas anderes nur halt mit dem makro das ich bekommen habe


  

Betrifft: AW: Spalte durchsuchen von: Tino
Geschrieben am: 07.01.2010 18:42:05

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


  

Betrifft: mir ist noch ein kleiner Fehler aufgefallen von: Tino
Geschrieben am: 07.01.2010 19:04:00

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


  

Betrifft: Sorry habe aber erst heute wieder eingeschaltet von: Ralf
Geschrieben am: 09.01.2010 12:35:30

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


  

Betrifft: danke für die positive Rückmeldung oT. von: Tino
Geschrieben am: 09.01.2010 12:44:23




Beiträge aus den Excel-Beispielen zum Thema "Spalte durchsuchen "