VBA te veel herhalen, kan dit korter

[HWV]

beste,

Ik heb een VBA code, die ik naar mijn inziens te veel herhaal
Is deze korter maken ?

Sheets("Layout").Select
ActiveSheet.Range("B8").End(xlDown).Offset(1, 1).Copy
Sheets("jaar").Range("B5:B5").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 4).Copy
Sheets("jaar").Range("B6:B6").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 7).Copy
Sheets("jaar").Range("B7:B7").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 10).Copy
Sheets("jaar").Range("B8:B8").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 13).Copy
Sheets("jaar").Range("B9:B9").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 16).Copy
Sheets("jaar").Range("B10:B10").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 19).Copy
Sheets("jaar").Range("B11:B11").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 22).Copy
Sheets("jaar").Range("B12:B12").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 25).Copy
Sheets("jaar").Range("B13:B13").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 28).Copy
Sheets("jaar").Range("B14:B14").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 31).Copy
Sheets("jaar").Range("B15:B15").Offset(0).PasteSpecial xlValues
ActiveSheet.Range("B8").End(xlDown).Offset(1, 34).Copy
Sheets("jaar").Range("B16:B16").Offset(0).PasteSpecial xlValues

Groet HWV

 

[geertd]

Ja, dat kan:

Je kunt bijvoorbeeld een Functie maken:

Function speciaalplakken (offset1 As Integer, offset2 As Integer, Range1 As String, Range2 As String, Range3 As String)
Sheets("Layout").Select
ActiveSheet.Range(Range1).End(xlDown).Offset(offset1, offset2).Copy
Sheets("jaar").Range(Range2 & ":" & Range3).Offset(0).PasteSpecial xlValues
End Function

'Voor de eerste zou je dan dit invullen:
speciaalplakken(1,1,"B8", "B5", "B5")
'etcetera....

Ik weet niet zeker of dat dit werk, omdat ik eigenlijk alleen programmeer in VB.NET.
Maar waarschijnlijk heb wel iets aan het bovenstaande.

Geert

 

[HWV]

Bedankt voor de reactie.
Helaas weet ik bijna niks van functie`s in VBA excel.
Liep al vast met

'Voor de eerste zou je dan dit invullen:
speciaalplakken(1,1,"B8", "B5", "B5")
'etcetera....

Ik had dat in een sub gezet maar :-(


Groet HWV

 

[Warme bakkertje]

Misschien met deze ?

Sub tst1()
i = 5
x = 1
Do Until i = 17
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, x).Copy Sheets("Jaar").Range("B" & i)
    x = x + 3
    i = i + 1
Loop
End Sub

 

[HWV]

Rudi,

Werkt weer als perfect.
Ik ga er in het weekend verder mee stoeien, en proberen uit te breiden.
ivm dat ik ook nog de kolommen daarnaast 2 stuks moet plaatsen in sheet jaar.
Een uitdaging maar ik ga het proberen

Groet HWV

 

[HWV]

Beste,

Ik ben tot het volgende resultaat gekomen.

Nu kopieer hij alles en ook de opmaak,hoe kan ik er voor zorgen dat hij alleen de waarde kopieert ?.
Ik heb de maanden van twee jaar naast elkaar staan, elke maand heeft een kolom omzet, marge en winst
Met de onderstaande code maak ik er een totaal overzicht van op blad "Jaar".

Ik wik kolom B,F,D,H als financieel
En kolom C en G in percentage
Hoe verwerk ik dit nu in de code ?

Selection.NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""_);_(@_)"

Selection.NumberFormat = "0%"

Sub JaarOmzet()
i = 5
x = 1
r = 2
s = 3
q = 37
j = 38
v = 39

Do Until i = 17
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, x).Copy Sheets("Jaar").Range("B" & i)
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, r).Copy Sheets("Jaar").Range("C" & i)
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, S).Copy Sheets("Jaar").Range("D" & i)
    
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, q).Copy Sheets("Jaar").Range("F" & i)
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, j).Copy Sheets("Jaar").Range("G" & i)
    Sheets("Layout").Range("B8").End(xlDown).Offset(1, v).Copy Sheets("Jaar").Range("H" & i)
  
    v = v + 3
    j = j + 3
    x = x + 3
    q = q + 3
    r = r + 3
    S = S + 3
    i = i + 1
Loop

End sub

Groet HWV

 

[Warme bakkertje]

Sub JaarOmzet()
i = 5
x = 1
r = 2
S = 3
q = 37
j = 38
v = 39

Do Until i = 17
    With Sheets("Jaar")
        .Range("B" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, x).Value
        .Range("C" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, r).Value
        .Range("D" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, S).Value
    
        .Range("F" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, q).Value
        .Range("G" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, j).Value
        .Range("H" & i) = Sheets("Layout").Range("B8").End(xlDown).Offset(1, v).Value
    End With
    i = i + 1
    x = x + 3
    r = r + 3
    S = S + 3
    q = q + 3
    j = j + 3
    v = v + 3
Loop
With Sheets("Jaar")
    .Range("B:B,D:D,F:F,H:H").NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""_);_(@_)"
    .Range("C:C,G:G").NumberFormat = "0%"
End With
End Sub

 

[HWV]

Gelukt

Rudi,

Bedankt voor de bijdrage wat dus natuurlijk ook gelijk de oplossing was. Perfect :thumb:

Bedankt voor je hulp

Groet HWV