• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

overzetten van gegevens naar ander tabblad, trage code

  • Onderwerp starter Onderwerp starter vio
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.

vio

Gebruiker
Lid geworden
18 jul 2007
Berichten
125
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
 
Code:
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
 
Laatst bewerkt:
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:cool:
Groet,
Ottavio
 
Foutjes hersteld en compleet gemaakt
Kan je volgende keer gebruik maken van de codetags, dat leest makkelijker

Mvg

Rudi
 

Bijlagen

Laatst bewerkt:
Vorige bijdrage verbeterd.
@Rudi
Clearcontents is overbodig, evenals clearcomments en achtergrondkleur, als daarna de cellen door de kopieeraktie overschreven worden.
 
Laatst bewerkt:
nog een foutje zie mijn bijlage
dubbel streepje voor bad en niet individueel

Mvg

Rudi
 
Re planning

Hoi,
fout 91 blijft tevoorschijn komen in een venstertje.
HTML:
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:confused: vermoedelijk ook één van de reden dat het zo traag loopt zeker??
Gegroet,
Vio
 

Bijlagen

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
 
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:confused: vermoedelijk ook één van de reden dat het zo traag loopt zeker??

:eek: Hoeveel zeg je?
 
Vio, probeer onderstaande eens en wat een monsterfile heb je daar.
Code:
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
 
Laatst bewerkt:
Yes

Hoi,
Alles werkt nu perfect nogmaals hartelijk dank ik kan morgen met een gerust hart naar het werk toe.:)
:o:o 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
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan