erg lange code

[pasan]

hallo

ik heb een werkende code die onzettend groot is ik vraag me af of deze code korter kan
iemand een tip?

[dagrapportage!c10] = [archiefdagrapportage!b65536].End(xlUp).Value
[dagrapportage!c11] = [archiefdagrapportage!b65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!c12] = [archiefdagrapportage!b65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!c13] = [archiefdagrapportage!b65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!c14] = [archiefdagrapportage!b65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!c15] = [archiefdagrapportage!b65536].End(xlUp).Offset(-5, 0).Value

[dagrapportage!d10] = [archiefdagrapportage!c65536].End(xlUp).Value
[dagrapportage!d11] = [archiefdagrapportage!c65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!d12] = [archiefdagrapportage!c65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!d13] = [archiefdagrapportage!c65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!d14] = [archiefdagrapportage!c65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!d15] = [archiefdagrapportage!c65536].End(xlUp).Offset(-5, 0).Value

[dagrapportage!e10] = [archiefdagrapportage!d65536].End(xlUp).Value
[dagrapportage!e11] = [archiefdagrapportage!d65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!e12] = [archiefdagrapportage!d65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!e13] = [archiefdagrapportage!d65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!e14] = [archiefdagrapportage!d65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!e15] = [archiefdagrapportage!d65536].End(xlUp).Offset(-5, 0).Value

zoals je ziet gaat het om kolom C , D en E.
ik heb nu 5 regels per kolom hier neer gezet in werkelijkheid gaat het om 300 regels totaal.
100 zoek regels per kolom
Kan dit ook in een kortere code gerealiseerd worden?

groet

Pasan:thumb:

 

[OctaFish]

Probeer dit eens...

For i = 0 To 5
    Me("dagrapportage!c1" & i) = [archiefdagrapportage!b65536].End(xlUp).Offset(-i, 0).Value
    Me("dagrapportage!d1" & i) = [archiefdagrapportage!c65536].End(xlUp).Offset(-i, 0).Value
    Me("dagrapportage!e1" & i) = [archiefdagrapportage!d65536].End(xlUp).Offset(-i, 0).Value
Next i

 

[pasan]

helaas OctaFish dit werkt niet
ik zal de het begin van de code in beeld zetten ik denk dat het dan nog iets duidelijker wordt

Sub Knop18_klikken()
'
' Knop18_Klikken Macro
' data wegschrijven naar archiefdagrapportage
ActiveSheet.Unprotect

Range("c6:e6").Copy Destination:=Sheets("archiefdagrapportage"). _
Range("B" & Sheets("archiefdagrapportage").Range("B65536").End(xlUp).Row + 1)


Range("dagrapportage!c6:e6").ClearContents
Range("d6") = Now()
Range("c6").Select
ActiveSheet.Unprotect
[dagrapportage!c10] = [archiefdagrapportage!b65536].End(xlUp).Value
[dagrapportage!c11] = [archiefdagrapportage!b65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!c12] = [archiefdagrapportage!b65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!c13] = [archiefdagrapportage!b65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!c14] = [archiefdagrapportage!b65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!c15] = [archiefdagrapportage!b65536].End(xlUp).Offset(-5, 0).Value

[dagrapportage!d10] = [archiefdagrapportage!c65536].End(xlUp).Value
[dagrapportage!d11] = [archiefdagrapportage!c65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!d12] = [archiefdagrapportage!c65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!d13] = [archiefdagrapportage!c65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!d14] = [archiefdagrapportage!c65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!d15] = [archiefdagrapportage!c65536].End(xlUp).Offset(-5, 0).Value

[dagrapportage!e10] = [archiefdagrapportage!d65536].End(xlUp).Value
[dagrapportage!e11] = [archiefdagrapportage!d65536].End(xlUp).Offset(-1, 0).Value
[dagrapportage!e12] = [archiefdagrapportage!d65536].End(xlUp).Offset(-2, 0).Value
[dagrapportage!e13] = [archiefdagrapportage!d65536].End(xlUp).Offset(-3, 0).Value
[dagrapportage!e14] = [archiefdagrapportage!d65536].End(xlUp).Offset(-4, 0).Value
[dagrapportage!e15] = [archiefdagrapportage!d65536].End(xlUp).Offset(-5, 0).Value

ActiveSheet.Protect




End Sub

groet

Pasan:thumb:

 

[OctaFish]

Ik dacht eigenlijk dat je een formulier met tekstvelden aan het vullen was o.i.d. Probeer het zo eens:

For i = 0 To 5
    Range("dagrapportage!c1" & i) = [archiefdagrapportage!b65536].End(xlUp).Offset(-i, 0).Value
    Range("dagrapportage!d1" & i) = [archiefdagrapportage!c65536].End(xlUp).Offset(-i, 0).Value
    Range("dagrapportage!e1" & i) = [archiefdagrapportage!d65536].End(xlUp).Offset(-i, 0).Value
Next i

Dit heb ik getest, en dat werkt...

 

[Warme bakkertje]

    x = 10
    For i = 2 To 4
        For ii = 0 To 99
            Sheets("dagrapportage").Cells(x, i + 1) = Sheets("archiefdagrapportage").Cells(65536, i).End(xlUp).Offset(ii * -1)
            x = x + 1
        Next
        x = 10
    Next

 

[pasan]

Warme bakkertje bedankt voor je hulp het werkt. 100 regels worden opgehaald
helaas wordt het ophalen en wegschrijfen er niet sneller op maar dat komt denk ik om dat er 100 regels tekst 2 keer gekopieerd worden (200 keer een kopie actie kost gewoon tijd). als ik het mis heb hoor ik het graag.
ook OctaFich heel erg bedankt voor je hulp. alleen jij hebt zoals in mijn voorbeeld maar 5 regels gebruikt om op tehalen.
als ik 0 to 5 verander in o to 99 komen de gegevens op een andere plek in de sheet te staan dan de bedoeling was.
de hele lijst word dan onder de bestaande lijst nogmaals weergegeven
bij o to 5 werkt hij inderdaad perfect
ik heb maar 3 keer 5 regels in de vraag hier gekopieerd omdat het anders zo groot zou worden.

Nogmaals heel erg bedankt heren voor jullie tijd

groet

Pasan:thumb:

 

[OctaFish]

De reden dat je geen of weinig snelheidswinst boekt komt doordat je steeds opnieuw een lokatie moet opzoeken. Als je dat verandert door één keer een startpositie op te zoeken en van daaruit de rest te vullen, wordt het denk ik al sneller. Dat mijn code niet voor alles blijkt te werken, komt overigens doordat je de vraag niet goed hebt gesteld, in combinatie met je voorbeeldcode. Let daar dus een volgende keer op, dat scheelt ons ook uitzoektijd.

 

[Warme bakkertje]

Als ik mijn stukje code laat lopen doet hij er bij mij 0.1sec over om 300 cellen te vullen.
Ik begrijp daarom jouw opmerking niet zo goed.
Staan er in jouw origineel bestand misschien veel formules die herberekend worden of id.?

 

[pasan]

OctaFich ik begrijp je opmerking volgende keer zal ik de gehele code dan ook kopieeren.
Warme bakkertje bij mij doet i er ietsje langer over maar dat zou ook aan mn pc kunnen liggen er staan overigens geen formules in die herberekent moeten worden
ik kan er mee leven.....

Heren mijn dank is groot

ik zet de vraag op opgelost

Mvg,

Pasan:thumb:

 

[Mark xl]

Probeer voor snelheidswinst in plaats van vele malen cellen uit te lezen en te schrijven te werken met een matrix. Het is niet zo heel moeilijk en werkt razendsnel, omdat er maar twee bewerkingen op het werkblad plaatsvinden.

Als deze code doet wat pasan bedoelt, werkt het waarschijnlijk stukken sneller.

Sub PatsBoem()
Dim avarInput As Variant
Dim avarOutput As Variant
Dim i As Long

    With Sheets("archiefdagrapportage")
        avarInput = Range(.Range("B65535").End(xlUp), _
                        .Range("B65535").End(xlUp).Offset(-99, 2))
    End With

    ReDim avarOutput(1 To UBound(avarInput, 1), _
                        1 To UBound(avarInput, 2))

    For i = LBound(avarInput, 1) - 1 To UBound(avarInput, 1) - 1
        avarOutput(UBound(avarInput, 1) - i, 1) = avarInput(i + 1, 1)
        avarOutput(UBound(avarInput, 1) - i, 2) = avarInput(i + 1, 2)
        avarOutput(UBound(avarInput, 1) - i, 3) = avarInput(i + 1, 3)
    Next
    
    With Sheets("dagrapportage")
        .Range("C10").Resize(100, 3) = avarOutput
    End With

End Sub

 

[pasan]

mark xl jou code is idd erg snel ik wil nog testen of hij ook in office 2000 werkt
thuis gebruik ik 2010 en hier werkt alles prima behalve nadat ik hem opsla als 97-2003
en hem op het werk gebruik met office 2000 de code van warme bakkertje werkte niet helemaal

Warme bakkertje ik had jou code in mn module geplakt en ik kom er vanavond achter nadat andere mensen met mijn programma gingen stoeien dat als ze meer dan +- 180 tekens in E6(dagrapportage) typen, en de rij hoogte wordt automatisch aangepast (ik zal die code er in plakken hier) Wordt de gehele tekst wel naar het archiefdagrapportage gekopieerd. En daar in het programma code staat de zelfde code om de regelhoogte automatisch aanpassen als in "dagrapportage". in het archief werk het prima. Maar het ophalen van het "archief" naar de "dagrapportage" krijg ik dan een fout waarde #waarde.

ofwel het komt doordat het office 2000 is ofwel de code voor het automatisch aanpassen rijhoogte klopt niet samen met jou code ik heb geen idee.
morgen test ik hoe de code van Mark xl werkt in office 2000

maar hier de code om de rijhoogte aan te passen

Sub Alt10()
  Dim c As Range, splits As Variant, i As Long
  ActiveSheet.Unprotect
  For Each c In Columns("C:E").SpecialCells(xlConstants)
    splits = Split(Trim(c), " ")
    For i = 0 To UBound(splits)
      If i <> 0 And Left(splits(i), 1) <> Chr(10) And Right(splits(i), 1) = "." And IsNumeric(splits(i)) Then
        splits(i) = Chr(10) & splits(i)
      End If
    Next
    c = Join(splits, " ")
  Next
  With Columns("C")
  .AutoFit
  .EntireRow.AutoFit
  End With
  ActiveSheet.Protect
End Sub

groet.
Pasan:thumb:

 

[pasan]

mark xl met jou code geen problemen en idd snel werkend
bedankt voor de support.

vraag opgelost

groet

Pasan:thumb: