Merge info from two sheets info one list

Question

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

Answer 1

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.