Is dit mogelijk via een loop functie

Status
Niet open voor verdere reacties.
E

ExcelTonnie

Gebruiker
Lid geworden
5 jul 2016
Berichten
308
Heb een invoer menu (userform) waar 70 invoervelden staan.
Er wordt een automatische test gedaan van 70stuks.
In het 1e veld komt een waarde en automatisch springt deze naar veld 2 enz. enz.
Deze waarden plaatst ik weer in een blad met aanvullende gegevens met de onderstaande code.

Invoer.JPG

De Txt zijn de invoervelden, zoals je ziet worden de eerste 10 waarden op regel 20 geplaatst en de volgende 10 waarden 9 regels verder.
Hier is dit veel code voor nodig om de 70 metingen in het tabblad te laten vullen.
Waarschijnlijk zal er iemand zeggen dan laat je dit toch gelijk in dit blad plaatsen. (niet de bedoeling)
Om deze korter te maken denk ik dat dit via een loop mogelijk moet zijn.
Iemand die me hierbij kan helpen.



Code: 
'Cav 1 t/m 10
ws1.Range("C20").Value = TxtCav1
ws1.Range("D20").Value = TxtCav2
ws1.Range("E20").Value = TxtCav3
ws1.Range("F20").Value = TxtCav4
ws1.Range("G20").Value = TxtCav5
ws1.Range("H20").Value = TxtCav6
ws1.Range("I20").Value = TxtCav7
ws1.Range("J20").Value = TxtCav8
ws1.Range("K20").Value = TxtCav9
ws1.Range("L20").Value = TxtCav10

'Cav 11 t/m 20
ws1.Range("C29").Value = TxtCav11
ws1.Range("D29").Value = TxtCav12
ws1.Range("E29").Value = TxtCav13
ws1.Range("F29").Value = TxtCav14
ws1.Range("G29").Value = TxtCav15
ws1.Range("H29").Value = TxtCav16
ws1.Range("I29").Value = TxtCav17
ws1.Range("J29").Value = TxtCav18
ws1.Range("K29").Value = TxtCav19
ws1.Range("L29").Value = TxtCav20

enz.enz
 
Kan inderdaad korter:
Code: 
    With ws1
        For i = 20 To 80 Step 10
            For j = 3 To 13
                x = x + 1
                Cells(i, j).Value = Me("TxtCav" & x)
            Next j
        Next i
    End With
 
AccessGuru zei:
Kan inderdaad korter:
Code: 
    With ws1
        For i = 20 To 80 Step 10
            For j = 3 To 13
                x = x + 1
                Cells(i, j).Value = Me("TxtCav" & x)
            Next j
        Next i
    End With
Klik om te vergroten...

Had het inmiddels anders bedacht, waardoor alles op dezelfde regel komt alleen de kolommen verschuiven.
wel de TxtCav1 t/m 70
en dit kan waarschijnlijk nog makkelijker in een loop.
Code: 
ws1.Cells(16, 23).Value = TxtCav1
ws1.Cells(16, 24).Value = TxtCav2
ws1.Cells(16, 25).Value = TxtCav3
ws1.Cells(16, 26).Value = TxtCav4
ws1.Cells(16, 27).Value = TxtCav5
ws1.Cells(16, 28).Value = TxtCav6
ws1.Cells(16, 29).Value = TxtCav7
ws1.Cells(16, 30).Value = TxtCav8
ws1.Cells(16, 31).Value = TxtCav9
ws1.Cells(16, 32).Value = TxtCav10
 
Dat doen we zo:

Code: 
Cells(16, 23).resize(,10)= array(TxtCav1,TxtCav2,TxtCav3,TxtCav4,TxtCav5,TxtCav6,TxtCav7,TxtCav8,TxtCav9,TxtCav10)
 
Da's een hoop typwerk snb, het moet dit worden:
Code: 
Cells(16, 23).resize(,[B]70[/B])= array(TxtCav1,TxtCav2,TxtCav3,TxtCav4,TxtCav5,TxtCav6,TxtCav7,TxtCav8, .. TxtCav69,TxtCav70)

Dan vind ik dit toch handiger:
Code: 
    With ws1
        For i = 23 To 93
           x = x + 1
           Cells(16, i).Value = Me("TxtCav" & x)
        Next i
    End With

Of:
Code: 
    With ws1
        For i = 23 To 93
           Cells(16, i).Value = Me("TxtCav" & i - 22)
        Next i
    End With
 
Het houdt de vingers soepel

Dan liever:

Code: 
redim sp(69)
for j=1 to 70
   sp(j-1)=me("T_" & format(j,"00"))
next

cells(16,1).resize(,ubound(sp)+1)=sp
 
1* schrijven naar een werkblad ipv 70 *
 
Mijne heren hartelijk dank voor jullie steun.

Ik ga voor de code van accessGuru deze is enigszins nog begrijpelijk voor mij.
Echter kreeg ik telkens een fout en heb 93 naar 92 gezet en toen werkte het wel.

Code: 
 With ws1
        For i = 23 To 93
           Cells(16, i).Value = Me("TxtCav" & i - 22)
        Next i
    End With

Uiteindelijk dus zo geworde:
Code: 
With ws1
        For i = 23 To [B]92[/B]
           Cells(16, i).Value = Me("TxtCav" & i - 22)
        Next i
    End With
    [B]Unload Me[/B]
 
Ik ga voor de code van accessGuru deze is enigszins nog begrijpelijk voor mij.
Klik om te vergroten...
1* schrijven naar een werkblad ipv 70 *
Klik om te vergroten...
Je offert de snelheid van je code op aan leesbaarheid.
Eigenlijk stopt SNB alles in een grote array en schrijft hij 1 keer naar je werkblad.
Verschil in tijd in dit geval ??? geen idee, fractie van een sec.
Maar als je dat vaker moet doen, dan zou ik toch daar even bij stilstaan.

Edit : even joyriding of miere_neu_ken (zonder streepjes)
Even voor de test een vergelijkbare oefening en de chronometer er bij gehaald, maar alles valt eigenlijk bij de nauwkeurigheid ervan (=1 cijfer na de komma).
Vergelijk het met het meten van 10 cm met een meetstok van een meter.
100 keer wegschrijven duurt 1/10", 1 blok wegschrijven is er een fractie van.
Dus voor een éénmalige actie is de tijdswinst minimaal.

Code: 
Sub wegschrijven()
Dim a()

t = Timer
For i = 1 To 100
Range("A" & i) = 1000
Next
MsgBox i & " keer schrijven : " & Timer - t


ReDim a(1 To i)
t = Timer
For i = 1 To UBound(a): a(i) = 1000: Next
Range("a1").Resize(, UBound(a)).Value = a
MsgBox "1 blok schrijven : " & Timer - t

End Sub
 
Laatst bewerkt:
Cow18

Is afhankelijk van:
het aantal formules in het werkblad
het aantal matrixformules in een werkblad
het soort formules in een werkboek (volatile)
het aantal UDF's in een werkboek
het aantal voorwaardelijke opmaakregels in een werkblad
het aantal dynamische benoemde gebieden

PS. Leesbaarheid is afhankelijk van leesvaardigheid
Grieks is bijv. voor sommigen onleesbaar, voor anderen niet.
 
Laatst bewerkt:
inderdaad, het was in een lege werkmap, dus een vertekend beeld
 

Bijlagen

  • Schermafbeelding 2021-11-22 120411.png
    Schermafbeelding 2021-11-22 120411.png
    22,5 KB · Weergaven: 23
cow18 zei:
Maar als je dat vaker moet doen, dan zou ik toch daar even bij stilstaan.
...100 keer wegschrijven duurt 1/10", 1 blok wegschrijven is er een fractie van.
Klik om te vergroten...
Ik vermoed dat snb in die tijd koffie zet, wat telefoontjes pleegt en de heg snoeit :d.
 
straks denken jullie dat ik geobsedeerd ben van mieren.
op een 2e blad 1000*1000 simpele formules en het nog een keer geprobeerd.
Er mag discussie ontstaan over de setup.
100 keer wegschrijven is hier nu 17 sec en 1 blok wegschrijven is 0.2 sec.
Die koffie wordt een Senseo.

Code: 
Sub wegschrijven()
     Dim a()
     Sheets("blad2").Range("a1").Resize(1000, 1000).FormulaR1C1 = "=NOW()+RAND()"     'vul op een 2e blad 1000*1000 formules in

     Sheets("blad1").Activate
     Randomize
     t = Timer
     For i = 1 To 100
          Range("A" & i) = Rnd()
     Next
     DoEvents
     xx = Range("a1").Value
     MsgBox i & " keer schrijven : " & Timer - t


     ReDim a(1 To i)
     t = Timer
     For i = 1 To UBound(a): a(i) = Rnd(): Next
     Range("a1").Resize(, UBound(a)).Value = a
     DoEvents
     xx = Range("a1").Value
     MsgBox "1 blok schrijven : " & Timer - t

End Sub
 
Gelukkig heb ik een snel besturingssysteem : XP.
 
Ben je nou cynisch of zwarte humor of grappig of gewoon "SNB" :d
 
Ik zie de laatste behoorlijk wat berichten langskomen dat MS er in 2022 hard aan gaat werken om Windows 11 sneller te krijgen.
Is nu blijkbaar nog niet het geval.
Ook bestaan er nogal wat snelheidsverschillen tussen de verschillende Officeversies.
Dus snelheid is niet alleen afhankelijk van keuzes in VBA.
Daarom hou ik als regel aan: doe in VBA zoveel mogelijk in het werkgeheugen. Welke kwalifikatie je daaraan hangt, zwart, cynisch, realistisch of idiosyncratisch is mij om het even.:)

Wordt het overigens geen tijd dat die vrolijke Sinterklaas in het logo van helpmij een mondkapje op gaat doen ?
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan