overzetten van gegevens naar ander tabblad, trage code

[vio]

Dag beste,
Ik kan mij aansluiten bij mensen die zeggen dit forum maakt me blij. Mensen zoals Roncancio, Warme bakkertje, Ginger, Wigi, snb enz....waar elk probleem moet buigen voor de knappe breinen. Nogmaals hartelijk dank.:thumb::thumb::thumb:
Zoals de titel al zegt heb ik een code die traag loopt. Is het mogelijk de code te versnellen?
Grtjs Vio

Sub Overzetten()
Range("C17:AF25").Select
Selection.Interior.ColorIndex = xlNone
Selection.ClearContents
Selection.ClearComments
Range("C27:AF28").Select
Selection.Interior.ColorIndex = xlNone
Selection.ClearContents
Selection.ClearComments
Range("C30:AF30").Select
Selection.Interior.ColorIndex = xlNone
Selection.ClearContents
Selection.ClearComments
Set Act = Worksheets("schoolzaken").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("schoolzaken").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C17").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("Luizen").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("Luizen").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C18").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("schoolzaken").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("schoolzaken").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C19").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("zwemm. sch").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("zwemm. sch").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C20").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("therapie overz.").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("therapie overz.").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C21").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("Wknd bezoek").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("Wknd bezoek").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C22").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("activ. overz.").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("activ. overz.").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C23").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("telefoon").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("telefoon").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C24").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("individueel").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("individueel").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C25").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("bad").Range("B8:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("bad").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C27").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("slaapritueel").Range("B7:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("slaapritueel").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C28").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set Act = Worksheets("extra kwartier").Range("B7:B1000").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
Worksheets("extra kwartier").Range("C" & Act.Row & ":AF" & Act.Row).Copy
Worksheets("planning").Range("C30").PasteSpecial Paste:=xlPasteAllExceptBorders
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Range("O14:T14").Select
ActiveCell.FormulaR1C1 = "=NOW()"
End Sub

 

[snb]

Sub planning()
  sq=split("schoolzaken|Luizen|schoolzaken|zwemm. sch|therapie overz.|Wknd bezoek|activ. overz.|telefoon||individueel|bad|slaapritueel||extra kwartier","|")
  for j=17 to 30
    if j<>26 and j<> 29 then sheets(sq(j-17)).columns(2).Find(Date, ,xlValues, xlWhole).offset(,1).resize(,30).Copy Worksheets("planning").cells(j,3)
  Next
End Sub

 

[vio]

Re

Hoi snb,
fout 91 komt tevoorschijn in een venstertje.
In de foutopsporing is er een gele markering vanaf:
Sheets(sq(j - 17)).Columns(2).Find(Date, , xlValues, xlWhole).Offset(, 1).Resize(, 29).Copy Worksheets("planning").Cells(j, 3)

Ik sta er versteld van dat het weer zo eenvoudig zou kunnen
Groet,
Ottavio

 

[Warme bakkertje]

Foutjes hersteld en compleet gemaakt
Kan je volgende keer gebruik maken van de codetags, dat leest makkelijker

Mvg

Rudi

 

[snb]

Vorige bijdrage verbeterd.
@Rudi
Clearcontents is overbodig, evenals clearcomments en achtergrondkleur, als daarna de cellen door de kopieeraktie overschreven worden.

 

[Warme bakkertje]

nog een foutje zie mijn bijlage
dubbel streepje voor bad en niet individueel

Mvg

Rudi

 

[vio]

Re planning

Hoi,
fout 91 blijft tevoorschijn komen in een venstertje.

sheets(sq(j-17)).columns(2).Find(Date, ,xlValues, xlWhole).offset(,1).resize(,30).Copy Worksheets("planning").cells(j,3)

Ik heb wel een gedeelte van mijn map in de bijlage gedaan om een voorbeeld te hebben hoe de cellen bijeen zijn gevoegd. Misschien kan dat wel de reden zijn van de fout??

Hopelijk heb ik de vraagstelling nu beter gesteld. Ik zou er het gans bestand wel willen bijvoegen maar het is veel te groot(2.500MB) In Excel 2007 zijn er ook zoveel kolommen en rijen meer vermoedelijk ook één van de reden dat het zo traag loopt zeker??
Gegroet,
Vio

 

[vio]

Gaat toch al wat sneller.

Hoi Rudi en snb,
Ik heb het eerste gedeelte in de lange code gezet (Clear Contenents etc..) en nu gaat de code toch al veel sneller. :thumb:Het zou natuurlijk af zijn als ik het helemaal via jullie code kon doen.
Grtjs,
Vio

 

[Wigi]

Ik zou er het gans bestand wel willen bijvoegen maar het is veel te groot(2.500MB) In Excel 2007 zijn er ook zoveel kolommen en rijen meer vermoedelijk ook één van de reden dat het zo traag loopt zeker??

Hoeveel zeg je?

 

[Warme bakkertje]

Vio, probeer onderstaande eens en wat een monsterfile heb je daar.

Sub planning()
Application.ScreenUpdating = False
On Error Resume Next
    sq = Split("schoolzaken|Luizen|schoolzaken|zwemm. sch|therapie overz.|Wknd bezoek|activ. overz.|telefoon|individueel||bad|slaapritueel||extra kwartier", "|")
        For j = 17 To 30
            If j <> 26 And j <> 29 Then Sheets(sq(j - 17)).Columns(2).Find(Date, , xlFormulas, xlWhole).Offset(, 1).Resize(, 30).Copy Worksheets("planning").Cells(j, 3)
        Next
Sheets("planning").[O14].Formula = "=NOW()"
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
End With
End Sub

Uitvoertijd getest ==>0,045699 sec

Mvg

Rudi

 

[vio]

Yes

Hoi,
Alles werkt nu perfect nogmaals hartelijk dank ik kan morgen met een gerust hart naar het werk toe.
2500 MB klopt inderdaad niet, het was 2,5 MB sorry voor de verkeerde info.

Nogmaals duizendmaal dank voor jullie prachtige oplossingen.
In Excel is blijkbaar alles mogelijk.:thumb:

Hartelijke groet,
Vio