Code verbeteren

[Evelthoven]

Goedemorgen,

Via het opnemen van macro en info. uit dit forum heb ik een macro gemaakt die er alsvolgt uit ziet.
Om weer wat bij te leren zou ik graag willen weten wat er aan deze code nog verbeterd/veranderd zou kunnen worden ?
Als jullie tijd hebben zou ik het fijn vinden als jullie er een keer naar willen kijken.

Sub Kopieren()
'

Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets(1).Select
    Range("B4:O1500").ClearContents
Sheets(2).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
    Range("b4").Select
    ActiveSheet.Paste
Sheets(3).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
Sheets(4).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
Sheets(5).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
   
Sheets(6).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
Sheets(7).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
Sheets(8).Select
    lastrow = Range("b65536").End(xlUp).Row
    Range("b5:o" & lastrow).Copy
    Sheets(1).Select
        Range("B65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    Range("b4").Select
 DeleteZero
 
 RefreshAllPivots
 
Application.EnableEvents = True
Application.ScreenUpdating = True

    
    
End Sub

De code regels "DeleteZero" en "RefreshAllPivots" zijn andere macro's die ik in deze macro heb gezet en die op zich goed werken.

Bedankt voor jullie reacties.

Groeten,
Eric

 

[Wigi]

Eric

voer deze macro eens uit, het zal je op een goed spoor zetten...

Sub BladenDoorlopen()
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Sheets
        With ws
            .Select
            MsgBox "Dit is het blad genaamd " & .Name
        End With
    Next
    
End Sub

Wigi

 

[Wigi]

Dit bedoel ik:

Sub Kopieren()

    Dim i As Byte
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Sheets(1).Select
    Range("B4:O1500").ClearContents
    
    For i = 2 To 8
        Set ws = Sheets(i)
        If i = 2 Then
            ws.Range("B5:O" & ws.Range("B" & Rows.Count).End(xlUp).Row).Copy Sheets(1).Range("B4")
        Else
            ws.Range("B5:O" & ws.Range("B" & Rows.Count).End(xlUp).Row).Copy Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next
    
    Range("B4").Select
    DeleteZero
    RefreshAllPivots
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

ongeteste code

Wigi

 

[Evelthoven]

Wim,

Erg bedankt dat je zo snel gereageerd hebt, maar had niet perse gehoeven, want ik denk dat er leden zijn van wie de vragen urgenter zijn dan deze vraag van mij.

Ik heb je code getest en deze werkt perfect. Het resultaat is hetzelfde.

Ik zou het heel plezierig vinden als je nog een keer uit zou willen leggen wat je code nu eigenlijk doet. Als je wilt zal ik de vraag al op opgelost zetten, maar ik denk als ik dat doe dat je deze dan misschien niet meer zult lezen, daarom laten ik het onderwerp nog even open staan.

Nogmaals bedankt,
Eric

 

[Wigi]

Het is gewoon een lus door de bladen. Leg jouw eigen code ernaast en je snapt het wel.

Bij de eerste keer kopiëren (vanaf blad 2) kopieer je naar cel B4, voor volgende tabbladen kopieer je naar de eerstvolgende lege rij.

Dit moet als leidraad volstaan denk ik.

Wigi

 

[Evelthoven]

Wim,

Bedankt, ga het nog verder bestuderen.

Eric