Copying data from one sheet to other in the same workbook is taking too long time

Hi All,
I want to copy the data (EPI Unit Price, Material Sales Status and Product Code) from the EPI_GP sheet to the Price_List sheet for the matching EPI Product Numbers in Price_List on a Apply Unit Price to PB button click.

After copying I need to replace the Material Sales Status code in Price_List with Name from Material_Status_Code for the matching codes.

The code is also there in the attached example.
It is working fine, but taking tooo longer time more than 15min and sometimes going into No Responding.

Please help me to optimize the code for this purpose in a simpler way without impacting the performance.

In real time will have thousands of rows in Price_List and EPI_List, where Price_List have more formula based columns.
As for example I just uploaded some sample data.

Please please please help me .... as this is is stopping to get the approval on the work done.

Thanks in advance.


Below is the code for reference.
Set DictData = CreateObject("Scripting.Dictionary")
'Iterator Worksheet 1, is the counter for the ws1 column
Dim iWS1 As Integer
'Iterator Worksheet 2, is the counter for the ws2 column
Dim iWS2 As Integer
'Maximal Row Count, need to be extend when new rows are added
Dim MaxRows As Integer
'valueHolder, is the holder for the orginal value, the orginal value might be replaced on the sheet
Dim valueHolder As Variant
'Worksheet1
Dim ws1 As Worksheet
'Worlsheet2
Dim ws2 As Worksheet
'Call UnprotectPriceList
Set ws1 = ThisWorkbook.Worksheets("Price_List")
Set ws2 = ThisWorkbook.Worksheets("EPI_GP")

Application.Calculation = xlCalculationManual
lastRow = ws2.Cells(Rows.count, "D").End(xlUp).Row
myArr = ws2.Range("D5:P" & lastRow)
firstEmptyRow = ws1.Cells(ws1.Rows.count, "D").End(xlUp).Row
If firstEmptyRow <= 5 Then
firstEmptyRow = 6
End If
'ThisWorkbook.Worksheets("Price_List").Activate

'Set iWS1 to the first row
iWS1 = 6
'Get MaxRows
MaxRows = ws1.Cells(Rows.count, 4).End(xlUp).Row

'Loop through the Rows on WS1 setting switch to 0 and store the value from the ws1 row in the holder
While iWS1 <= MaxRows
valueHolder = ws1.Cells(iWS1, 11).Value

''Loop through the Rows on WS2, searching for a value that match with the value from ws1
'For iWS2 = 5 To ws2.Cells(Rows.count, 5).End(xlUp).Row
' 'When it matches, then look if there was already a match with the value, if not replace it on the ws1 and increase the sNr to 1
' If valueHolder = ws2.Cells(iWS2, 4).Value Then
' ws1.Cells(iWS1, 15).Value = ws2.Cells(iWS2, 9).Value
' ws1.Cells(iWS1, 19).Value = ws2.Cells(iWS2, 16).Value
' ws1.Cells(iWS1, 33).Value = ws2.Cells(iWS2, 6).Value
' End If
'Next iWS2

For i = 1 To UBound(myArr)
' 'When it matches, then look if there was already a match with the value, if not replace it on the ws1 and increase the sNr to 1
If valueHolder <> "" Then
If valueHolder = myArr(i, 1) Or valueHolder = Replace(myArr(i, 1), " ", "") Then
ws1.Cells(iWS1, 15).Value = myArr(i, 6)
ws1.Cells(iWS1, 19).Value = myArr(i, 13)
ws1.Cells(iWS1, 33).Value = myArr(i, 3)
End If
End If
Next
iWS1 = iWS1 + 1
Wend

Try:

Please Login or Register  to view this content.

You are very welcome.