# Merge info from two sheets info one list

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

• The guidelines for how to ask questions on Code Review are a little confusing, but generally speaking, questions should contain more larger picture context of what you use this code for. If you edit your question to follow this convention, you may get more views. – puzzlepiece87 Feb 27 '19 at 19:49

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().

1. 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().

1. 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.

1. 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

1. 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

1. 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)

1. 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

1. 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.