• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

controle vba macro

Status
Niet open voor verdere reacties.
J

johanrr

Gebruiker
Lid geworden
24 jan 2010
Berichten
33
Hallo Vba expert

Na veel zoeken en hulp van dit forum heb ik een macro in elkaar gepuzzeld. Het werkt maar is redelijk langzaam. Mogelijk zit er teveel in of kan iets eenvoudiger.
Kan iemand hier overheen kijken of iets weg of eenvoudiger kan? wat er gebeurt staat erbij:

Sub huubmacro()
'opheffen beveiliging
ActiveSheet.Unprotect
'wijzigen woord bouwgroepelement in tekeningnummer
Sheets("Berekeningsprotocol").Cells.Replace What:="Bouwgroepelement", Replacement:="Omschrijving/tekeningnummer"
'aantal cellen leegmaken wat weg moet
Sheets("Berekeningsprotocol").Range("c1:I1").ClearContents
Sheets("Berekeningsprotocol").Range("c2:I2").ClearContents
'regels verwijderen die weg moeten
Rows("2998:3000").Select
Selection.Delete Shift:=xlUp
Rows("181").Select
Selection.Delete Shift:=xlUp
'kolommen a en h verwijderen
Columns("$A:$A").EntireColumn.Hidden = True
Columns("$H:$H").EntireColumn.Hidden = True
'logo vergroten en regel groter maken
Rows("1:1").RowHeight = 90
Sheets("Berekeningsprotocol").Select
With ActiveSheet.Pictures
.Height = 90
.Top = [A1].Top
.Left = [A1].Left
End With
'verbreden cellen zodat het past
Columns("G:G").ColumnWidth = 7.86
Columns("I:I").ColumnWidth = 12.14
'verwijderen prijsinfo
ActiveSheet.Unprotect ' Alle rijen van het bereik aflopen
For Each c In Range("$B$2:$B$" & Range("B65500").End(xlUp).Row)
' Checken of de woorden 'behandeling" of 'bewerking' aanwezig zijn in kolom B
If InStr(1, c.Text, "Trumpf", 1) Or InStr(1, c.Text, "Lasersnijden", 1) Or InStr(1, c.Text, "afruimen", 1) Then
' Als WAAR dan rij verbergen
Rows(c.Row).Hidden = True
' Einde vraag
End If
' Volgende rij
Next
' Einde macro
End Sub




Sub tonen()
' Alle verborgen rijen terug zichtbaar maken
Range("A:A").Rows.Hidden = False
ActiveWorkbook.Save
Range("C2:I2").Select
ActiveWindow.Close
Application.Run "PERSONAL.XLSB!huubmacro"
ActiveWindow.SmallScroll Down:=-9
Range("A16:I16").Select
ActiveWindow.Close
Application.Run "PERSONAL.XLSB!huubmacro"
Application.Goto Reference:="huubmacro"
ActiveWorkbook.Save
End Sub

alle info is welkom.

Groet
Johan
 
Begin je macro met :

Application.ScreenUpdating = False

en eindig met :

Application.ScreenUpdating = True
 
Zet graag de code tussen codetags op het forum.
Bvd.
 
controle

Beste Harry,

Wat bedoel je met tags, dit is zo uit vba gecopierd.

Beste Aelatik,

Waarvoor dient de screenupdate?

Johan
 
Screenupdate is het bijwerkeren van de weergave tijdens macro acties.
Er gebeuren heel veel acties vanuit macro. Als Excel dat ook nog eens probeert te presenteren dan consumeert het bijna 300% performance.
 
Selecteer de code in het venster, en druk op de #.
Application.screenupdating gaat het flikkeren van het beeld tegen; de code loopt sneller.
 
controle met codetag

Code: 
Sub huubmacro()
Application.ScreenUpdating = False
'opheffen beveiliging
ActiveSheet.Unprotect
'wijzigen bouwgroepelement in teknr
Sheets("Berekeningsprotocol").Cells.Replace What:="Bouwgroepelement", Replacement:="Omschrijving/tekenmingnummer"
'aantal cellen leegmaken wat weg moet
Sheets("Berekeningsprotocol").Range("c1:I1").ClearContents
Sheets("Berekeningsprotocol").Range("c2:I2").ClearContents
'regels verwijderen ivm tekening die erin staan
Rows("2998:3000").Select
    Selection.Delete Shift:=xlUp
Rows("181").Select
    Selection.Delete Shift:=xlUp
'kolommen a en h verwijderen a jpg en h is prijsinfo
Columns("$A:$A").EntireColumn.Hidden = True
Columns("$H:$H").EntireColumn.Hidden = True
'logo vergroten en regel groter maken
Rows("1:1").RowHeight = 90
Sheets("Berekeningsprotocol").Select
With ActiveSheet.Pictures
.Height = 90
.Top = [A1].Top
.Left = [A1].Left
End With
'verbreden cellen zodat het past
 Columns("G:G").ColumnWidth = 7.86
 Columns("I:I").ColumnWidth = 12.14
'verwijderen prijsinfo
    ActiveSheet.Unprotect ' Alle rijen van het bereik aflopen
  For Each c In Range("$B$2:$B$" & Range("B65500").End(xlUp).Row)
' Checken of de woorden 'behandeling" of 'bewerking' aanwezig zijn in kolom B
            If InStr(1, c.Text, "Trumpf", 1) Or InStr(1, c.Text, "Lasersnijden", 1) Or InStr(1, c.Text, "afruimen", 1) Then
' Als WAAR dan rij verbergen
       Rows(c.Row).Hidden = True
' Einde vraag
 End If
' Volgende rij
Next
Application.ScreenUpdating = True

' Einde macro
End Sub





Sub tonen()
' Alle verborgen rijen terug zichtbaar maken
         Range("A:A").Rows.Hidden = False
    ActiveWorkbook.Save
    Range("C2:I2").Select
    ActiveWindow.Close
    Application.Run "PERSONAL.XLSB!huubmacro"
    ActiveWindow.SmallScroll Down:=-9
    Range("A16:I16").Select
    ActiveWindow.Close
    Application.Run "PERSONAL.XLSB!huubmacro"
    Application.Goto Reference:="huubmacro"
    ActiveWorkbook.Save
    Application.Run "PERSONAL.XLSB!huubmacro"
    ActiveWindow.SmallScroll Down:=-18
    ActiveWindow.Close
End Sub
 
Dat ziet er beter uit.
Laat de rijen een beetje verspringen; leest gemakkelijker.
Verwijder eens 'Select en Selection' in de code.

En als je dit hebt:
Code: 
Sheets("Berekeningsprotocol").Range("C1:I1").ClearContents
Sheets("Berekeningsprotocol").Range("C2:I2").ClearContents
Kun je het beter zo zetten.
Code: 
Sheets("Berekeningsprotocol").Range("C1:I2").ClearContents
 
Beste Harry,

Ja dat is nog korter, ok.

moet de voor elk commando ook aangeven welke sheet dat hij dit moet doen, of pakt hij altijd het huidige werkblad. Er zijn +- 10 werkbladen die later verborgen worden.

Gr.
Johan
 
Ik heb wat with end with's toegevoegd en eea wat herschreven:
Code: 
Sub huubmacro()
Dim c As Range

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    With Sheets("Berekeningsprotocol")
        .Unprotect 'opheffen beveiliging
        .Cells.Replace What:="Bouwgroepelement", Replacement:="Omschrijving/tekenmingnummer" 'wijzigen bouwgroepelement in teknr
        .Range("c1:I2").ClearContents 'aantal cellen leegmaken wat weg moet
        .Rows("2998:3000").Delete Shift:=xlUp 'regels verwijderen ivm tekening die erin staan
        .Rows("181").Delete Shift:=xlUp
        .Range("$A:$A,$H:$H").EntireColumn.Hidden = True 'kolommen a en h verwijderen a jpg en h is prijsinfo
        .Rows("1:1").RowHeight = 90 'logo vergroten en regel groter maken
        
            With .Pictures
                .Height = 90
                .Top = [A1].Top
                .Left = [A1].Left
            End With
            
        .Columns("G:G").ColumnWidth = 7.86 'verbreden cellen zodat het past
        .Columns("I:I").ColumnWidth = 12.14
        
        For Each c In .Range("$B$2", .Cells(Rows.Count, 2).End(xlUp)) 'verwijderen prijsinfo Alle rijen van het bereik aflopen
        ' Checken of de woorden 'behandeling" of 'bewerking' aanwezig zijn in kolom B  Als WAAR dan rij verbergen
                If InStr(1, c.Text, "Trumpf", 1) Or InStr(1, c.Text, "Lasersnijden", 1) Or InStr(1, c.Text, "afruimen", 1) Then Rows(c.Row).Hidden = True
        Next
        
      End With

      With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
      End With
' Einde macro
End Sub

Ben ervanuitgegaan dat alles op 1 sheet "Berekeningsprotocol" gebeurt
De grootste verrtaging zou de for next loop nog kunnen zijn, is wellicht mbv een filter nog sneller te maken.

Daarnaast volg ik jouw Sub Tonen niet helemaal.....je start 3 maal dezelfde macro?
 
Hallo Eric,

Werkt ook thnx. De sub tonen is blijven staan bij knippen/plakken.
bedankt voor de contoles heren.

Gr. Johan
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan