Code sneller maken

[Jack Nouws]

Hallo

Bestaat er een mogelijkheid om deze code sneller te maken?

Met vr gr
Jack

Sub Macro1()
Dim MyRange             As Variant
Dim c                   As Range
Dim legeregel           As Integer
Sheets("FustOverzicht").Range("B6:L28").ClearContents

For Each c In Sheets(Range("F1").Value).Range("B5:B100")
    If c <> "" Then
        Workbooks("Fust Registratie").Sheets("FustOverzicht").Unprotect
        legeregel = Workbooks("Fust Registratie").Sheets("FustOverzicht").Range("B65536").End(xlUp).Row + 1

Sheets("FustOverzicht").Range("B" & legeregel) = Sheets(Range("F1").Value).Range("B" & c.Row)
Sheets("FustOverzicht").Range("C" & legeregel) = Sheets(Range("F1").Value).Range("C" & c.Row)
Sheets("FustOverzicht").Range("D" & legeregel) = Sheets(Range("F1").Value).Range("D" & c.Row)
Sheets("FustOverzicht").Range("E" & legeregel) = Sheets(Range("F1").Value).Range("E" & c.Row)
Sheets("FustOverzicht").Range("F" & legeregel) = Sheets(Range("F1").Value).Range("F" & c.Row)
Sheets("FustOverzicht").Range("G" & legeregel) = Sheets(Range("F1").Value).Range("G" & c.Row)
Sheets("FustOverzicht").Range("H" & legeregel) = Sheets(Range("F1").Value).Range("H" & c.Row)
Sheets("FustOverzicht").Range("I" & legeregel) = Sheets(Range("F1").Value).Range("I" & c.Row)
Sheets("FustOverzicht").Range("J" & legeregel) = Sheets(Range("F1").Value).Range("J" & c.Row)
Sheets("FustOverzicht").Range("K" & legeregel) = Sheets(Range("F1").Value).Range("K" & c.Row)
Sheets("FustOverzicht").Range("L" & legeregel) = Sheets(Range("F1").Value).Range("L" & c.Row)
End If
Next c

End Sub

 

[Roncancio]

Onderstaande regel buiten de lus halen en vervangen door een teller (legeregel = legeregel + 1) in de lus.

        legeregel = Workbooks("Fust Registratie").Sheets("FustOverzicht").Range("B65536").End(xlUp).Row + 1

Met vriendelijke groet,


Roncancio

 

[Wigi]

En SpecialCells of een autofilter gebruiken om de lus zoveel mogelijk te vermijden.

En kopiëren ipv. cel per cel overhalen aangezien het een aaneengesloten bereik is.

Wigi

 

[Roncancio]

Je haalt de Protection van het werkblad af maar het zet het niet terug ?!



Met vriendelijke groet,


Roncancio

 

[Finch]

Als die c="" enkel is voor "echt" lege cellen, dus niet voor een cel die leeg is, maar waar toch een formule in staat, dan kan je dat ook opvangen door specialcells(xlcelltypeblank). Anders een autofilter gebruiken, zo kan je een lus uitsparen.

edit: wigi was me voor

 

[Wigi]

edit: wigi was me voor

Als de boodschap dan nog niet overkomt...

Fijn weekend hé Bert

 

[Jack Nouws]

Fijn weekend hé Bert

Ik moet er nog even over nadenken of het echt wel een probleem is dat het wat langzamer is.
Oja mijn naam is Jack en geen Bert

Met vr gr
Jack

 

[snb]

Deze oneliner doet hetzelfde als jouw code

Sub kopieer()
  Sheets(Range("F1").Value).Range("B5:L100").copy Workbooks("Fust Registratie").Sheets("FustOverzicht").Range("B65536").End(xlUp).offset(1)
End Sub

Als je nog wil fijnslijpen:

Sub kopieer()
  Sheets(Range("F1").Value).Range("B5:L100").copy Workbooks("Fust Registratie").Sheets("FustOverzicht").Range("B65536").End(xlUp).offset(1)
  Workbooks("Fust Registratie").Sheets("FustOverzicht").columns(2).specialcells(xlcelltypeblanks).entirerow.delete
End Sub

Verder nog een dringend advies