Regels controleren op aantallen en dan de gegevens (x) Keer overneem op Blad 2

[WWillems]

Ik heb een bestand waar ik regels controleer op aantallen en dan de gegevens overneem op Blad2.

Er moet per regel gekeken worden naar het aantal bakken kolom [E] Maximaal 15st.
Dan moet het bereik A van die regel overgenomen worden op Blad2. Dus staat er in Kolom [E] 3 dan moet die regel 3x onder elkaar gezet worden.
Dit moet herhaald worden voor 40 artikelen.
Omdat het iedere keer een ander aantal is laat ik deze ver uit elkaar op Blad2 verschijnen en haal ik via een code de lege cel regels weg.

Nu heb ik dat voor elkaar gekregen met 6 artikel regels, Alleen wordt het bestand dan al enorm traag en ik moet er nog 34.
Ik verwacht dat het beter en sneller kan. Alleen krijg ik niet de juiste code gevonden om dit voor elkaar te krijgen.

Kan iemand mij helpen?


Zie de code hieronder.

Sub Artikel1Starten()
'
' Macro tbv aantal x kopieren van artikel 1
'

'


'
'   Screenundating uitzetten
'
With Application
 
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
 
End With

'
'   Cel E2 Leeg dan Exit sub
'
If IsEmpty(Range("E2").Value) Then
Exit Sub

End If

'
'   Artikel 1 plakken 1x
'
If Sheets("Blad1").Range("E2").Value = 1 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D1").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 2x
'
If Sheets("Blad1").Range("E2").Value = 2 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D2").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 3x
'
If Sheets("Blad1").Range("E2").Value = 3 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D3").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 4x
'
If Sheets("Blad1").Range("E2").Value = 4 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D4").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 5x
'
If Sheets("Blad1").Range("E2").Value = 5 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D5").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 6x
'
If Sheets("Blad1").Range("E2").Value = 6 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D6").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 7x
'
If Sheets("Blad1").Range("E2").Value = 7 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D7").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 8x
'
If Sheets("Blad1").Range("E2").Value = 8 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D8").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 9x
'
If Sheets("Blad1").Range("E2").Value = 9 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D9").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 10x
'
If Sheets("Blad1").Range("E2").Value = 10 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D10").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 11x
'
If Sheets("Blad1").Range("E2").Value = 11 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D11").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 12x
'
If Sheets("Blad1").Range("E2").Value = 12 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D12").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 13x
'
If Sheets("Blad1").Range("E2").Value = 13 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D13").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 14x
'
If Sheets("Blad1").Range("E2").Value = 14 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D14").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If
'
'   Artikel 1 plakken 15x
'
If Sheets("Blad1").Range("E2").Value = 15 Then
    Range("A2:D2").Select
    Selection.Copy
    Sheets("Blad2").Select
    Range("A1:D15").Select
    ActiveSheet.Paste
    Sheets("Blad1").Select
    Range("A1").Select
    Application.CutCopyMode = False
End If

End Sub

Sub Legecellen()
'
' Legecellen Macro
'

'
    Cells.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
End Sub

 

[edmoor]

Probeer dit maar eens in plaats van al dat kopiëren en plakken wat de boel erg traag maakt:

 Sheets("Blad2").Range("A1:D1").Value = Sheets("Blad1").Range("A1:D1").Value

De controle en ranges mag je zelf doen.

 

[VenA]

Als de kleurtjes niet mee hoeven

Sub VenA()
With Sheets("Blad1")
    ar = .Cells(1).CurrentRegion
    ReDim ar1(1 To Application.Sum(.Columns(5)), 1 To 4)
End With
For j = 2 To UBound(ar)
    If ar(j, 5) <> "" Then
        For jj = 1 To ar(j, 5)
            t = t + 1
            For jjj = 1 To 4
                ar1(t, jjj) = ar(j, jjj)
            Next jjj
        Next jj
    End If
Next j
With Sheets("Blad2").Cells(1)
    .CurrentRegion.ClearContents
    .Resize(UBound(ar1), 4) = ar1
End With
End Sub

Of met een tragere copy actie

Sub VenA1()
With Sheets(2)
    For Each cl In Sheets(1).Columns(5).SpecialCells(2, 1)
        cl.Offset(, -4).Resize(, 4).Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(cl.Value, 4)
    Next cl
End With
End Sub

 

[WWillems]

Wat een snelle reactie, Dank jullie wel!

VenA je oplossing werkt prima, Ik begrijp nog niet veel van je code maar ga er nog verder induiken.
De kleuren zijn niet nodig, heb dit gedaan om voor mij makkelijk verschil te zien met het testen.

Zou je me nog wel kunnen vertellen hoe ik het invoegen op Blad2 kan aanpassen naar regel2?
Dan kan ik namelijk standaard de koptekst van regel 1 hier ook neer zetten.

 

[VenA]

With Sheets("Blad2").Cells(1).Offset(1)

 

[HSV]

Zo gaan de kopteksten automatisch mee.
Dan hoef je ze er niet steeds opnieuw weer in te zetten door de 'clearcontents' die vanaf A1 alles weer wist.

Ik heb er twee regels ingezet die allebeide evengoed werken (een mag je er verwijderen).

With Sheets("Blad2").Cells(1)
    .CurrentRegion.ClearContents
    '.Resize(, 4) = Array(ar(1, 1), ar(1, 2), ar(1, 3), ar(1, 4)) 'deze regel
    .Resize(, 4) = Sheets("Blad1").Cells(1).Resize(, 4).Value  'of deze regel
    .Offset(1).Resize(UBound(ar1), 4) = ar1
    .Columns(1).Resize(, 4).AutoFit
End With

 

[VenA]

Scherp:d

Zo kan het ook als de kolomkoppen al ingevuld zijn.

With Sheets("Blad2").Cells(1).CurrentRegion.Offset(1)
    .ClearContents
    .Resize(UBound(ar1), 4) = ar1
    .Columns(1).Resize(, 4).AutoFit
End With

 

[WWillems]

Mijn dank, werkt precies zoals ik gehoopt had!