Vwwxrf

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 the 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 the 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

I'm seeing a few things you could do to improve your code. I won't focus just on speed considerations.

1. 
   

   Explicitly qualify your objects. Don't let Excel make any assumptions about them. Letting Excel make assumptions leads to frustrating, unpredictable, hard to diagnose errors.

   
   
   
   • 
     Before: Sheets()
     
   
   
   • 
     After: ThisWorkbook.Sheets().
   
   

2. 
   

   Use Worksheets() instead of Sheets(), because Sheets() can also refer to ListObjects I believe. This will help you avoid referring to the wrong object.

   
   
   
   • 
     Before: .Sheets()
     
   
   
   • 
     After: .Worksheets().
   
   

3. 
   

   You should use multiple Sub()s to accomplish this purpose. Your existing sub is too long and has too many variables. Using multiple subs will help you more quickly pinpoint errors and ease code reuse.

   
   
   
   • 
     Before: Everything in SpecialCopy()
     
   
   
   • 
     After: SpecialCopy() broken into multiple pieces, each of which has its own Sub() or Function() with a descriptive name describing what it does. Each Sub() or Function() you create is stored in the same module and you execute those names inside SpecialCopy() to execute those code pieces.
   
   

4. 
   

   You should use one variable on each line to make your code easier to read. Following the above recommendation to use multiple Sub()s will help you have fewer variables active at a time, decreasing your memory footprint and eliminating the need to put multiple variables on the same line to conserve screen space.

   
   
   
   • 
     Before: Dim rw As Range, rng_fOp As Range, item_mini As Long, item_no As Long, fetch_row As Long, op_no As Long
     
   
   
   • 
     After: Dim rw As Range as one line with the rest on subsequent lines
   
   

5. 
   

   If you have worksheets you know ahead of time you want to refer to, give them names in the Project Explorer.

   
   
   
   • 
     Before: Sheets("ProdRows_Mo").Range
     
   
   
   • 
     After: ProdRows_Mo.Range`
   
   

6. 
   

   Get rid of .End(xlUp)(1) after .Cells(1,1). It's not accomplishing anything.

   
   
   
   • 
     Before: Sheets("OpRows_Mo_copy").Cells(1, 1).End(xlUp)(1)
     
   
   
   • 
     After: Sheets("OpRows_Mo_copy").Cells(1, 1)
     
   
   

7. 
   

   Indent code inside blocks. After using For, For Each, Do While, With, etc., your next lines shouldn't be spaced with the same left margin.

   
   
   
   • 
     Before: Do While j < lr_op / With Worksheets("OpRows_Mo_copy") / lr_op = Sheets("OpRows_Mo_copy").Cells(Rows.Count, 1).End(xlUp).Row
     
   
   
   • 
     After: Do While j < lr_op / (indent) With Worksheets("OpRows_Mo_copy") / (2x indent) lr_op = Sheets("OpRows_Mo_copy").Cells(Rows.Count, 1).End(xlUp).Row
     
   
   

8. Every time you want to cycle through every cell in a range, just read it into an array. Every time you refer to a cell's value on a worksheet via a range object, Excel has to read it from the worksheet, one of the more time-expensive operations it does. Instead, load the range into an array in memory, and you can quickly test every value without having to touch the worksheet. Here, you can use my function:

Private Function ConvertRangeToArray(ByVal rngInQuestion As Range) As Variant

 Dim arrRangeToArray() As Variant
 With rngInQuestion
 If .Cells.Count = 1 Then
 ReDim arrRangeToArray(1 To 1, 1 To 1)
 arrRangeToArray(1, 1) = .Cells(1, 1).Value
 Else
 arrRangeToArray = .Value
 End If
 End With

 ConvertRangeToArray = arrRangeToArray

End Function

This is enough to get you started. Good effort on your code, I look forward to seeing you improve further.