Gfrktyl

I've created a code that works, but takes time to run.

Is there any way of making this code work in a more efficient way?

In short terms I want to:

• make a new copy of sheet 1 and 2




• Select the row with lowest value in sheet 1



• Paste this row in sheet 3, and select item-number, rownumber and OP-number from this row



• Delete copied row in sheet 1




• Select row from sheet 2 with the same item-number, rownumber and that has the LOWEST rownumber



• Paste this row in sheet 3


• Delete copied row in sheet 2

Sheet 1 contains 34.000 rows and sheet 2 about 57.000 rows.
This means I'm making a lot of loops in this existing code, and I'm looking for any way to improve this code to work faster.

CODE:

Option Explicit

Sub SpecialCopy()



'~~> 1. Copy sheets to new locations

Dim lr_op As Long, lr_prod As Long, rng_cProd As Range, rng_cOp As Range



'~~> Copy products to new sheet

lr_prod = Sheets("ProdRows_Mo").Cells(Rows.Count, 1).End(xlUp).Row

Set rng_cProd = Sheets("ProdRows_Mo").Range("A27:A" & lr_prod - 27)

rng_cProd.EntireRow.Copy Sheets("ProdRows_Mo_copy").Cells(1, 1).End(xlUp)(1)



'~~> Copy op to new sheet

lr_op = Sheets("OpRows_Mo").Cells(Rows.Count, 1).End(xlUp).Row

Set rng_cOp = Sheets("OpRows_Mo").Range("A27:A" & lr_op - 27)

rng_cOp.EntireRow.Copy Sheets("OpRows_Mo_copy").Cells(1, 1).End(xlUp)(1)



'~~> End 1



'~~> 2. Loop op page for lowest value in "A"



'~~> Count rows in OpRows_copy

Dim rw As Range, rng_fOp As Range, item_mini As Long, item_no As Long, fetch_row As Long, op_no As Long

Dim j As Long, i As Range, vmin As Long, found As Range, item_no_comp As Long, pos_value As Integer, bel_to_op As Long



Do While j < lr_op



With Worksheets("OpRows_Mo_copy")



lr_op = Sheets("OpRows_Mo_copy").Cells(Rows.Count, 1).End(xlUp).Row

Set rng_fOp = Sheets("OpRows_Mo_copy").Range("A1:A" & lr_op)



vmin = Application.WorksheetFunction.Min(rng_fOp)

'MsgBox ("OP " & vmin & "-" & vmin)



Set i = Sheets("OpRows_Mo_copy").Range("A1:A" & lr_op).Find(what:=vmin, LookIn:=xlValues, lookat:=xlWhole)



        item_no = .Cells(i.Row, 6).Value

        op_no = .Cells(i.Row, 20).Value

        fetch_row = i.Row



        'Copy the other cells in the row containing the minimum value to the new worksheet.

        Sheets("OpRows_Mo_copy").Cells(fetch_row, 1).EntireRow.Copy Sheets("ProdRows_PY").Cells(Rows.Count, 1).End(xlUp).Offset(1)



        'Insert pos_value to copied row

        If item_no_comp = item_no Then

            pos_value = pos_value + 10

        Else

            pos_value = 10

            item_no_comp = item_no

        End If

        Sheets("ProdRows_PY").Cells(Rows.Count, 5).End(xlUp).Offset(1).Value = pos_value



        'Delete the "old" row

        Sheets("OpRows_Mo_copy").Rows(fetch_row).Delete



        'Set op-no row to

        bel_to_op = pos_value



End With



'~~> End 2



'~~> 3. Loop prod page for lowest value

Dim x As Range, y As Range, c_rows As Integer, row_no As Long, rng_fProd As Range, pos_no As Long, counter As Integer



'~~> Count rows in prodRows_copy



With Worksheets("ProdRows_Mo_copy")



Do



lr_prod = Sheets("ProdRows_Mo_copy").Cells(Rows.Count, 1).End(xlUp).Row

Set rng_fProd = Sheets("ProdRows_Mo_copy").Range("A1:A" & lr_prod)



    For Each y In rng_fProd



        If item_no = .Cells(y.Row, 7).Value And op_no = .Cells(y.Row, 14).Value Then



            If pos_no = 0 Then

                row_no = y.Row

                pos_no = .Cells(y.Row, 12).Value



            ElseIf pos_no > 0 And pos_no > .Cells(y.Row, 12).Value Then



                row_no = y.Row

                pos_no = .Cells(y.Row, 12).Value

            End If



        Else

        End If



    Next y







        If pos_no = 0 Then

            'endOfProd = True

            Exit Do

        Else

            'Copy the other cells in the row containing the minimum value to the new worksheet.

            Sheets("ProdRows_Mo_copy").Cells(row_no, 1).EntireRow.Copy Sheets("ProdRows_PY").Cells(Rows.Count, 1).End(xlUp).Offset(1)



            'Insert PY-pos_value to copied row

            If item_no_comp = item_no Then

                pos_value = pos_value + 10

            Else

                pos_value = 10

                item_no_comp = item_no

            End If







            Sheets("ProdRows_PY").Cells(Rows.Count, 5).End(xlUp).Offset(1).Value = pos_value

            Sheets("ProdRows_PY").Cells(Rows.Count, 5).End(xlUp).Offset(0, -1).Value = bel_to_op



            'Delete the "old" row

            Sheets("ProdRows_Mo_copy").Rows(row_no).Delete



            row_no = 0

            pos_no = 0



         End If



Loop



End With



lr_op = lr_op - 1

Loop



End Sub