Excel VBA kopieren als() versnellen

[MC trouble]

Hey,

De code die ik dacht te gaan gebruiken is erg traag. Er wordt per rij gekeken of kolom U en O leeg zijn. Als ze leeg zijn worden er 15 cellen naar een ander tabblad gekopieerd.

Het duurd 1 minuut 22 om op "blad2" naar 240 rijen te kijken en 627 cellen te kopiëren naar "blad1". Ik heb zo nog een stuk of 15 pagina's en ik zou graag iets beters willen maken waarbij er geen 20 minuten gewacht hoeft te worden.

code:

Application.ScreenUpdating = False
Application.EnableEvents = False


For i = 5 To Max + 5
      Set cellAL = wsTPL.Cells(i, "U") 
      Set cellAL2 = wsTPL2.Cells(i, "O")
        If Not InStr(cellAL, "") Or InStr(cellAL2, "") Then    
          wsTemperatuurmetingen.Cells(j, "B").Value = Chr(39) & wsTPL.Cells(i, "C").Value
            'nog 14 keer de bovenstande regels voor andere cellen
          j = j + 1
      End If
    Next i

  Application.ScreenUpdating = True
  Application.EnableEvents = True

Wat ik al gevonden of geprobeerd heb;


- Het zoeken naar "" is langzaam en is vervangen door vbNullString. Scheele bijna 2 seconden.
- De data opslaan in een array en dan kopiëren zou veel sneller zijn
- 64 bit scheelde helaas niets, maar misschien dat het opslaan in een array veel Ram kost?
- Excel een hogere prioriteit geven in Task Manager scheelde 10% (hoogst gaat goed. Op Real Life begint spotify te storen , maar wel ~90% cpu op 8 "cores" (i7-6700))
- Van .xlsm naar xlsb scheelde misschien een seconden, maar wel heel veel in het bestand zelf (van 14 mb naar 6,5 mb)
- Er zouden wat cellen die naast elkaar staan als range verwerkt kunnen worden;

code:

 wsTemp.Range(Cells(j, "O").Address(), Cells(j, "T").Address()) = ......

in plaats van;

code:

  wsTemp.range(j, "I").Value = ...........

- De code wordt uitgevoerd nadat het hele tabblad ingevuld is, voordat alles geëxporteerd wordt en als het doel
blad geopend wordt door de invuller. Als de er geen veranderingen zijn mbt het doel blad wordt er niets
uitgevoerd. Als er 1 regel veranderd wil ik deze invoegen in het doel blad. Dit blad is al zo ontworpen dat
er een extra regel ingevoegd kan worden.

We zijn al aan het werk met de sheets, dus ik zou mij graag op de dingen met de grootste tijdwinst willen focussen. Wat heel veel scheelde (met dank aan Breew);

code:

 - Application.Calculation = xlCalculationManual
'de code
- Application.Calculation = xlCalculationAutomatic

Dit scheelt al; 99% tot de sheets meer dan 600 regels krijgen dan wordt het allemaal weer wat trager.

********** Update ***********

Kwam net dit topic tegen en heb de Union() functie van breew nog even getest en gebruikt in me macro. De Bij het kopiëren van 3 cellen over 50.000 regels is Union een 30% sneller dan de cell.value = cell.value. De code draait 3 keer beide versies en kopieert de zelfde 150.000 cellen naar hetzelfde gebied en schrijft de tijd die het duurt in het DeBug scherm

1 Union2 = Union1 01,66
2 cell2 = cell1 02,71
3 Union2 = Union1 01,66
4 cell2 = cell 02,27
5 Union2 = Union1 01,65
6 cell2 = cell 02,27

code:

Sub UnionTest()
'Application.SendKeys "^g ^a {DEL}"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim StartTime As String

With ThisWorkbook
  Dim Ws1 As Worksheet: Set Ws1 = .Sheets("verwijzingen")
  Dim Ws2 As Worksheet: Set Ws2 = .Sheets("test")

StartTime = Timer
          For i = 6 To 50000
              Union(Ws2.Cells(i, 4), Ws2.Cells(i, 5), Ws2.Cells(i, 6)).Value = Union(Ws1.Cells(i, 1), Ws1.Cells(i, 2), Ws1.Cells(i, 3)).Value
          Next
Debug.Print "1 Uni2 = Uni1   "; Format(Timer - StartTime, "00.00")
  
          i = 0
StartTime = Timer
          For i = 6 To 50000
            Ws2.Cells(i, "H").Value = Ws1.Cells(6, "A").Value
            Ws2.Cells(i, "I").Value = Ws1.Cells(6, "B").Value
            Ws2.Cells(i, "J").Value = Ws1.Cells(6, "C").Value
          Next

Debug.Print "2 Ws2 = Ws1     "; Format(Timer - StartTime, "00.00")
          i = 0
StartTime = Timer
          For i = 6 To 50000
              Union(Ws2.Cells(i, 4), Ws2.Cells(i, 5), Ws2.Cells(i, 6)).Value = Union(Ws1.Cells(i, 1), Ws1.Cells(i, 2), Ws1.Cells(i, 3)).Value
          Next
Debug.Print "3 Uni2 = Uni1   "; Format(Timer - StartTime, "00.00")
  
          i = 0
StartTime = Timer
          For i = 6 To 50000
            Ws2.Cells(i, "H").Value = Ws1.Cells(i, "A").Value
            Ws2.Cells(i, "I").Value = Ws1.Cells(i, "B").Value
            Ws2.Cells(i, "J").Value = Ws1.Cells(i, "C").Value
          Next
        
Debug.Print "4 Ws2 = Ws1     " & Format(Timer - StartTime, "00.00")
          i = 0
StartTime = Timer
          For i = 6 To 50000
              Union(Ws2.Cells(i, 4), Ws2.Cells(i, 5), Ws2.Cells(i, 6)).Value = Union(Ws1.Cells(i, 1), Ws1.Cells(i, 2), Ws1.Cells(i, 3)).Value
          Next
Debug.Print "5 Uni2 = Uni1   "; Format(Timer - StartTime, "00.00")
  
          i = 0
StartTime = Timer
          For i = 6 To 50000
            Ws2.Cells(i, "H").Value = Ws1.Cells(i, "A").Value
            Ws2.Cells(i, "I").Value = Ws1.Cells(i, "B").Value
            Ws2.Cells(i, "J").Value = Ws1.Cells(i, "C").Value
          Next

Debug.Print "6 Ws2 = Ws1     "; Format(Timer - StartTime, "00.00")

          End With
i = 0


  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic

End Sub

[ Voor 110% gewijzigd door MC trouble op 01-02-2018 09:29 . Reden: Misschien dat iemand er eens iets aan heeft. ]

[breew]

Je gaat celvalues aanpassen in een (grote?) forloop
Heb je

Application.ScreenUpdating = False

al geprobeerd?
niet vergeten weer op True te zetten!!

Zo zijn er nog een aantal systeemvariabelen die je uit kunt schakelen gedurende het doorlopen van je vba code.
Herberekenen op manual, etc...

[MC trouble]

Ik heb niet eens de tijd gehad om mijn vraag te updaten :-P


Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic

De code duurt nu minder dan 4 seconden

Op zich is alles nu snel genoeg, maar ik heb tijd om hem te verbeteren. Dus als er tips zijn hoor ik het graag!

[ Voor 22% gewijzigd door MC trouble op 12-12-2017 16:39 ]

[breew]

Waarom 15x 1 cel kopiëren, als je in 1x een range van 15 cellen kunt kopiëren?

Visual Basic:

Worksheets("Sheet1").Range("A1:A15").Copy destination:=Worksheets("Sheet2").Range("A1")

niet-aaneengesloten ranges kun je samenvoegen met Union()

Lege cellen kun je direct checken met

cel.value <> ""

dan hoef je niet steeds het bereik in te stellen, en kun je ook de "Instr()" functie achterwege laten.

[ Voor 79% gewijzigd door breew op 12-12-2017 17:06 ]

[MC trouble]

Helaas staat niet alles naast elkaar en er wordt nog wat geschoven met de layout. Wanneer alles vast ligt maak ik er ranges van. Er blijven dan echter nogsteeds 4 losse ranges over.

A =ALS(B13="";"";RIJ()-12)
B =C
C tm F = G tm J

Dit verschilt per doel blad, maar er zijn 3 tot 6 verschillende ranges per blad.

***edit***

Ik kan mij niet meer heugen waarom ik Instr() gebruikt heb. Cell.Value = " ... " lijkt in ieder geval ook te werken.

[ Voor 17% gewijzigd door MC trouble op 12-12-2017 17:29 ]

[breew]

MC trouble schreef op dinsdag 12 december 2017 @ 17:10:
Ik kan mij niet meer heugen waarom ik Instr() gebruikt heb. Cell.Value = " ... " lijkt in ieder geval ook te werken.

Ik snap iid niet wat je ermee zou willen bereiken. Met Instr() zoek je een startpositie van een substring in een string, het is niet bepaald de meest geschikte methode om lege cellen te zoeken (denk ik, maar ik laat me graag corrigeren)...

verdere tips over efficiency:
https://www.soa.org/News-...com-2012-iss42-roper.aspx

[ Voor 12% gewijzigd door breew op 12-12-2017 20:12 ]

[MC trouble]

Het gaat niet enkel om lege cellen. Er wordt op andere bladen ook naar text en cijfers gezocht.

Bedank voor de link. Daarmee kan ik nog wel wat verbeteren!