zelfde kunstje op twee andere tabbladen

[Depant]

Hallo allemaal,

Onderstaand stukje werkt echt super, hartelijk dank en credits aan wampier.
Ik wil echter in dat excelwerkblad nog 2 tabbladen toevoegen met exact hetzelfde kunstje.
Moet dat apart of kan ik dit uitbreiden?
De namen van de tabbladen kan ik zelf wel maken.
Kan iemand mij helpen?

Bekijk bijlage sorry2.xlsm




Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [a1]) Is Nothing Then
vanaf = Application.WorksheetFunction.Sum([a1])
Application.ScreenUpdating = False
Application.EnableEvents = False
[c3:an65000].ClearContents
For Each comp In Sheets("plak215").Range(Sheets("plak215").[b3], Sheets("plak215").[b500000].End(xlUp))
If Application.WorksheetFunction.Sum(comp) >= vanaf Then
If Application.WorksheetFunction.Sum(Sheets("plak215").Range(comp.Offset(0, 8), comp.Offset(0, 27))) > 0 Then
For i = 0 To 19
If Application.WorksheetFunction.Sum(comp.Offset(0, 8 + i)) > 0 Then

monster = comp.Offset(0, 1).Value
Set doelcel = Cells(200000, 3 + 2 * i).End(xlUp).Offset(1)
doelcel.Value = comp.Value
doelcel.Offset(0, 1).Value = monster
End If
Next i
End If
End If

Next comp

 

[edmoor]

Zet hem in:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dan heb je de code maar 1x nodig en kun je controleren wat het actieve blad is via sh.Name

 

[Depant]

Hallo

Goedenavond,

Bedankt voor je antwoord, maar ik heb daar nu nog weinig kennis voor.
Ik heb voor de zekerheid maar een bestandje geüpload.
Maar ik ga het zeker nog proberen.

En trouwens als ik hem een ietwat anders moet maken, hoe werkt het dan??

Maar mega bedankt met op het goede spoor zetten.:thumb::thumb:

 

[edmoor]

In bijgaand document heb ik de voorgestelde wijziging gemaakt.
De code staat dus niet meer achter het blad gew maar in de ThisWorkbook sectie.
Tevens zit er een eenvoudig aan te passen controle in dat hij nu alleen werkt voor het blad gew.
Die controle kan je dus uitbreiden door er gewoon meerdere bladnamen in op te nemen.

Bekijk bijlage sorry2.xlsm

 

[Depant]

Bedankt voor je reactie

Hallo edmoor,

Maar als ik hem iets wil aanpassen. ( ze zijn te enthousiast op mijn werk)
Ik kan toch niet dezefde gebruiken, omdat je andere tabbladen gebruikt.
Moet ik hem er dan onder kopiëren met gebruik van de andere namen van de andere tabbladen.??
Je snapt wel waarom ik diegene ben die de vragen stelt


Als ik dit klaar is ga ik kerst vieren

Bij voorbaat hartelijk dank

 

[edmoor]

Als die code al goed werkte op het blad gew hoef je er verder niets aan te veranderen als inderdaad exact hetzelfde kunstje voor de 2 andere bladen moet worden gedaan. Je hoeft dan alleen maar in de controle de namen van die 2 andere bladen op te nemen:

Select Case LCase(Sh.Name)
    Case "gew", "ander blad 1", "ander blad 2"
    Case Else
        Exit Sub
End Select

Wel in kleine letters, ongeacht de naam van het blad.
Je hoeft dus verder niks te kopiëren of aan te passen als die 2 andere bladen verder gelijk zijn aan het blad gew.

 

[Depant]

Goedenavond

Ik begrijp dat ik niet duidelijk ben. Dat is niet mijn sterkste punt.
Wat ik op mijn wensenlijst voor een vroege kerst heb is het volgende.


Ik krijg een nieuwe uitvoer in excel die ik plak in "plak211"
Ik wil daar onafhankelijk van de andere 2 tabbladen ook dat kunstje doen. ( tenminste als dat kan)
De selectie moet dan tercht in gro komen.

Ik vraag veel, maar weet weinig


Bekijk bijlage edmoor2.xlsm

 

[edmoor]

Onder "hetzelfde kunstje" begrijp ik "dezelfde code uitvoeren". En dat is precies wat er gebeurt.
Als dat niet de bedoeling is zal je toch echt een uitgebreidere uitleg moeten geven.

 

[Depant]

Goedenavond

Excuus voor mijn onkunde. En gebrek aan uitlegvermogen.

plak 215 + kunstje geeft selectie en schrijft weg naar gew. perfect!!
Plak 211 + kunstje geeft selectie en schrijft weg naar gro.

Bij mijn laatste upload heb ik het tabblad inplak11 erbij gedaan.( moest qua naam natuurlijk211 zijn)
ik probeer dat stukje in plak211 te plakken maar dat lukt niet, omdat ik die macro niet goed heb aangepast...

Kan je nog voor de laatste keer kijken??

Henk Harbers

 

[edmoor]

Ik wil best nog een keer kijken of ik snap wat je bedoelt maar dat wordt dan morgenavond. Maar goed, we hebben nog even tot het kerst is

 

[Depant]

Kerst

:thumb::thumb::thumb:

Hallo Edmoor,

Ik heb hem gekopieerd naar het andere tabblad.
Namen erin verandert en het werkt.
Bedankt voor je hulp en geduld.

Fijne kerstdagen :thumb::thumb:

 

[Depant]

Hallo allemaal,

Voordat ik weer tot 11 uur met glazige ogen bezig ben, om een kleine aanpassing te doen leek het me beter om de vraag beter maar gelijk hier te stellen.
De vraag is perfect opgelost, ik wil alleen nog weten hoe ik de kolommen kan aanpassen.
Ik wil eigenlijk bij kolom 10 beginnen in plak 215.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [a1]) Is Nothing Then
vanaf = Application.WorksheetFunction.Sum([a1])
Application.ScreenUpdating = False
Application.EnableEvents = False
[c2:an30000].ClearContents
For Each comp In Sheets("plak215").Range(Sheets("plak215").[b3], Sheets("plak215").[b30000].End(xlUp))
If Application.WorksheetFunction.Sum(comp) >= vanaf Then
If Application.WorksheetFunction.Sum(Sheets("plak215").Range(comp.Offset(0, 8), comp.Offset(0, 27))) > 0 Then
For i = 0 To 19
If Application.WorksheetFunction.Sum(comp.Offset(0, 8 + i)) > 0 Then

monster = comp.Offset(0, 1).Value
Set doelcel = Cells(200000, 3 + 2 * i).End(xlUp).Offset(1)
doelcel.Value = comp.Value
doelcel.Offset(0, 1).Value = monster
End If
Next i
End If
End If

Next comp

Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub

Bijvoorbaat hartelijk dank