• 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.

VBA-code verkorten

Status
Niet open voor verdere reacties.
W

wieter

Terugkerende gebruiker
Lid geworden
26 jun 2009
Berichten
1.128
In de onderstaande code wordt 8 x dezelfde routine herhaald, telkens voor een ander blad, met een andere voorwaarde.
Kan die code verkort worden tot 1 routine?

Bekijk bijlage Antje.xlsm

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
With Sheets("Dag1")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("A:A").SpecialCells(2)
If cl.Value = "1" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Dag2")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("A:A").SpecialCells(2)
If cl.Value = "2" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Dag3")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("A:A").SpecialCells(2)
If cl.Value = "3" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Dag4")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("A:A").SpecialCells(2)
If cl.Value = "4" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Leiding")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("B:B").SpecialCells(2)
If cl.Value = "leiding" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Catering")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("B:B").SpecialCells(2)
If cl.Value = "catering" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Huisvesting")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("B:B").SpecialCells(2)
If cl.Value = "huisvesting" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
With Sheets("Communicatie")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("B:B").SpecialCells(2)
If cl.Value = "communicatie" Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
 
Je kunt daar toch eenvoudig een for-nextlus aan toevoegen?
Als het de bladen van 1 t/m 8 zijn gebruik je:
Code: 
Dim sh as integer
For sh = 1 to 8
with sheets(sh)
.....
......
end with
next sh
En zijn het andere bladnummers, dan begin je met een ander nummer.
Staan ze niet opeenvolgend, dan kun je de bladnamen in een array onderbrengen en alsnog van 1 t/m 8 doorlopen.
 
Laatst bewerkt:
Klopt Zapatr, een For-Next lus voor de tabbladen.
Maar in elke routine zit ook nog een if -voorwaarde, die voor elk blad anders is.
Er zou dus nog een lus voor die voorwaarde moeten ingebouwd worden, en dat is mijn probleem.
 
tip: zet die voorwaarde op elk tabblad op een vaste plaats en verwijs in de routine naar die plaats...
 
Goede tip Paradoxx, ga het gelijk uittesten.
 
Code: 
Sub macro1()
Dim sh As Integer, myvalue As String
Application.ScreenUpdating = False
For sh = 1 To 8
With Sheets(sh)
myvalue = WorksheetFunction.Choose(sh, "1", "2", "3", "4", "Leiding", "Catering", "Huisvesting", "Communicatie")
.Range("A5:N" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range("A:A").SpecialCells(2)
If cl.Value = myvalue Then
cl.EntireRow.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
End With
Next sh
Application.ScreenUpdating = True
End Sub
Waarom je een "Private sub" gebruikt, blijkt niet uit je bericht,
Eigenlijk moet je ook testen of er wel specialcells van het type 2 aanwezig zijn, anders zul je foutmeldingen krijgen, en het blad TOTAAL mag uiteraard niet het nummer 1 t/m 8 hebben.
 
Laatst bewerkt:
@Paradoxx, jou idee werkt perfect, bedankt.

@Zapatr, PrivateSub omdat elke wijziging in het blad de code moet activeren
Specialcells(2) omdat de cellen alleen tekst of getallen zullen bevatten
Ga ook gelijk jou code proberen toe te passen
Bedankt
 
Je hebt mijn code niet goed overgenomen; in de functie choose vergeet je de blauwe tekst:
Code: 
myvalue = WorksheetFunction.Choose([COLOR="#0000CD"]sh[/COLOR], "1", "2", "3", "4")
Maar los daarvan: ik zie dat je bladen niet opeenvolgend staan wat nummering betreft, zodat je de code toch nog twee keer gebruikt. Ik zal dat proberen aanpassen, even geduld. Maar nog wel een vraag: in de macro kijk je of de woorden "Leiding", "Catering", "Huisvesting", en "Communicatie" in het blad "Totaal" in kolom A voorkomen. Maar in je voorbeeldbestand komen in die kolom die woorden helemaal niet voor. Is dat toeval of moet in de code kolom A voor de laatste 4 bladen kolom B zijn?
 
Zapatr, bedankt voor je inzet.
Ik herhaal de code 2 x
Eerste keer kijken of (1, 2, 3, 4) voorkomen in kolom A
Tweede keer kijken of (huisvesting, catering, leiding, communicatie) voorkomen in kolom B
Ik was dat blauwe deel inderdaad vergeten in de code.
Bedankt
 
@zapatr

VBA bevat de eigen funktie choose(n,..,..,), veel sneller dan de Excelfunktie.

@wieter

Het is gebruikelijk (want veel sneller en minder complex) om dit soort dingen op te zetten als een database, zoals in jouw werkblad Totaal.
Daarna heb je geen afzonderlijke werkbladen meer nodig, want kun je op allerlei mogelijke criteria filteren in de database (per dag of combinatie, per soort aktivitiet of combinatie, per 'bijzonderheden', etc.)
Dan heb je ook helemaal geen VBA nodig, want die filtermogelijkheden zijn allemaal al ingebouwd in Excel: autofilter, advancedfilter en de mogelijkheden van de tabel (listboject) in Excel 2007 en 2010.
 
@snb
Die filtermogelijkheden in excel ken ik.
Maar om de lange winter door te komen, experimenteer ik zo maar wat met VBA-routines.
 
Uitgaande van je bestand in bericht #9, waarin de bladen waarvoor de code moet werken opeenvolgend staan, zou dit het moeten doen:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl as range, sh As Integer, mystr As String
'Deze macro werd geschreven door Zapatr
Application.ScreenUpdating = False
For sh = 2 To 9
With Sheets(sh)
mystr = "A5:A": If sh > 5 Then mystr = "B5:B"
.Range("A5:N" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).ClearContents
For Each cl In Sheets("Totaal").Range(mystr & Cells(Rows.Count, 1).End(xlUp).Row)
If cl.Value = WorksheetFunction.Choose(sh, "", 1, 2, 3, 4, "leiding", "catering", "huisvesting", "communicatie") Then
cl.EntireRow.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)
Sheets(sh).Columns("A:N").EntireColumn.AutoFit
End If
Next cl
End With
Next sh
Application.ScreenUpdating = True
End Sub
 
Zapatr, gewoonweg SUBLIEM!!
Nu het net doorzoeken om die Choose-functie goed onder de knie te krijgen.
En zoals gewoonijk, bij het lezen van specialisten-codes, is de logica duidelijk.
Maar zelf die logica opbouwen, HOU MAAR!
Super bedankt, Zapatr, veel bijgeleerd.
 
T'is wat...

Code: 
Sub M_snb()
   sn = Sheets("totaal").Cells(4, 1).CurrentRegion
   
   For j = 2 To UBound(sn)
        Sheets("Dag" & sn(j, 1)).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Application.Index(sn, j, 0)
        Sheets(sn(j, 2)).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Application.Index(sn, j, 0)
   Next
End Sub
 
Whaw snb , wat is dit zeg!
Mijn oorspronkelijk probeersel van 72 regels herleid jij zo maar eens eventjes naar 5 regels.
Heb jij je VBA-kennis in een ander zonnestelsel opgedaan?
Het zal mij wel een tijd duren om dit te doorgronden.
Bedankt voor de uitdaging.
Grtn Wieter
 
"In de beperking toont zich de meester."
Goethe (1749-1832)
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan