Code sneller laten verlopen

[HWV]

Beste,

Is er een mogelijkheid om onderstaande code sneller te laten verlopen.
Het is een onderdeel van meerdere van deze code`s achter elkaar en heeft betrekking op ongeveer 9000 regels.

Sub Verplaatsen_ArtikelConversieOutput1_naar_ConversieOutput()

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

On Error Resume Next
For j = 2 To Sheets("ArtikelConversie Output").Cells(Rows.count, 1).End(xlUp).Row
With Sheets("ArtikelConversie Output1").Columns(1).Find(Sheets("ArtikelConversie Output").Cells(j, 1).Value)
.Offset(, 21).Resize(, 20).Copy Sheets("ArtikelConversie Output").Cells(j, 22)
.Offset(, 50).Copy Sheets("ArtikelConversie Output").Cells(j, 51)
.Offset(, 52).Copy Sheets("ArtikelConversie Output").Cells(j, 53)
End With
Next

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub

Groet HWV

 

[snb]

Probeer eens:

For each cl in  Sheets("ArtikelConversie Output").columns(1).specialcells(xlcelltypeconstants)
  if cl.row > 1 then
    With Sheets("ArtikelConversie Output1").Columns(1).Find(cl.Value)
      cl.Resize(,20)=.Offset(, 21).Resize(, 20)
      cl.Offset(, 50)=.Offset(, 50) 
      cl.Ofset(j, 52)=.Offset(, 52)
    End With
  end if
Next

 

[HWV]

Foutmelding fout 1004 tijdens uitvoering

Beste SNB,

Bedank voor uw input.
Helaas krijg ik een foutmelding
Fout 1004 tijdens uitvoering
Door de toepassing of door object gedefineerde fout
op de regel :

Sheets("ArtikelConversie Output").Cells(j, 22).Resize(, 20) = .Offset(, 21).Resize(, 20)

Als ik deze regel overslaat dan geef hij bij de eerst opvolgende een foutmelding.

Sub TestNieuweCode()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

For Each cl In Sheets("ArtikelConversie Output").Columns(1).SpecialCells(xlCellTypeConstants)
  If cl.Row > 1 Then
    With Sheets("ArtikelConversie Output1").Columns(1).Find(cl.Value)
      Sheets("ArtikelConversie Output").Cells(j, 22).Resize(, 20) = .Offset(, 21).Resize(, 20)
      Sheets("ArtikelConversie Output").Cells(j, 51) = .Offset(, 50)
      Sheets("ArtikelConversie Output").Cells(j, 53) = .Offset(, 52)
    End With
  End If
Next

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

Groet HWV

 

[Warme bakkertje]

Vervang in de code 'j' eens door cl.Row

 

[HWV]

Helaas

Sub TestNieuweCode()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

For Each cl In Sheets("ArtikelConversie Output").Columns(1).SpecialCells(xlCellTypeConstants)
  If cl.Row > 1 Then
    With Sheets("ArtikelConversie Output1").Columns(1).Find(cl.Value)
      Sheets("ArtikelConversie Output").Cells(cl.Row, 22).Resize(, 20) = .Offset(, 21).Resize(, 20)
      Sheets("ArtikelConversie Output").Cells(cl.Row, 51) = .Offset(, 50)
      Sheets("ArtikelConversie Output").Cells(cl.Row, 53) = .Offset(, 52)
    End With
  End If
Next

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

Helaas werkt het ook niet met bovenstaande code, ik heb het ook nog even veranderd in het oorspronkelijke bericht maar daar krijg ik de zelfde melding.

Groet HWV

 

[snb]

Vorige suggestie aangepast

 

[HWV]

Sub TestCode()
On Error Resume Next
For Each cl In Sheets("ArtikelConversie Output").Columns(1).SpecialCells(xlCellTypeConstants)
  If cl.Row > 1 Then
    With Sheets("ArtikelConversie Output1").Columns(1).Find(cl.Value)
     ' cl.Resize(, 20) = .Offset(, 21).Resize(, 20)
      cl.Offset(, 50) = .Offset(, 50)
      cl.Offset(, 52) = .Offset(, 52)
    End With
  End If
Next
End Sub

Na toevoeging van een F een de J weg gehaald voor de 52 en er een On Error Resume Next te hebben toegevoegd ging het al beter.
Enkel de eerste kolom met de artikelnummers werd weggehaald doormiddel van de regel

cl.Resize(, 20) = .Offset(, 21).Resize(, 20)

Deze niet actief gemaakt en hij loopt door.
Omdat ik nu op een terminal werkt vanuit huis zal ik morgen pas kunnen zeggen of hij sneller is als de eerste code.

Tot zover alvast weer bedankt

Groet Henk

 

[HWV]

Sneller

Beste,

De code uitgeprobeerd en is sneller als de eerste code.
Uiteindelijk heb ik de "On Error Resume Next" er uit gehaald ivm dat hij bepaalde regels oversloeg. Doormiddel van de opmaak van mijn artikelnummers, kreeg ik de foutmelding, ik heb deze gekopieerd en enkel de waarde weer terug gezet en nu draait de code wel goed.
Ik heb een test gedraaid op 1000 regels met mijn eerste code deed hij er 30 seconden over, en de nieuwe 13 seconden, dus de code is een absolute aanwinst mijn dank hiervoor

Groet Henk