Copy Values to Below last Populated Cell Q

[John]

I am trying to copy values in Trade up Meals cells A9; B9; J18; K18; L18;
N18; O18 (and for every 12th Row below these values) to a sheet called
Ingredient Products starting on the row below the last populated cell.

I am using the following code but am getting very unreliable data, does the
code look ok?

Thanks

Sub TradeupCostToIngredients_Post()
Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Trade Up Meals")
Set rng = Union(.Range("A9"), .Range("B9"), .Range("J18"), .Range("K18"),
..Range("L18"), .Range("N18"), .Range("O18"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
l = l + 1
k = Worksheets("Ingredient Products").Cells(Rows.Count,
l).End(xlUp).Row + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Ingredient Products") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 12
Loop
Next
End With

Sheets("Ingredient Products").Select

Columns("B:B").Select
Columns("B:B").EntireColumn.AutoFit

Columns("C:G").Select
Application.CutCopyMode = False
Selection.NumberFormat = "#,##0.00"
Range("A1").Select

Set rng = Range("A1:G1").Resize(Cells(Rows.Count, "A").End(xlUp).Row, 7)
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select

Sheets("Master").Select
Range("A1").Select

End Sub

 

[Bernie Deitrick]

John,

Try the code below to see if it improves your results.

HTH,
Bernie
MS Excel MVP

Sub TradeupCostToIngredients_Post2()
Dim i As Long
Dim myStartRow As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim mySht As Worksheet

Set mySht = Worksheets("Ingredient Products")

myStartRow = mySht.Cells(mySht.Rows.Count, 1).End(xlUp)(2).Row

With Worksheets("Trade Up Meals")
Set Rng1 = Union(.Range("A9"), .Range("B9"))
Set Rng2 = Union(.Range("J18"), .Range("K18"), _
.Range("L18"), .Range("N18"), .Range("O18"))

For i = 0 To .Range("A65536").End(xlUp).Row Step 12
Set Rng1 = Union(Rng1, Rng1.Offset(i, 0))
Next i

Rng1.Copy mySht.Cells(myStartRow, 1)

For i = 0 To .Range("A65536").End(xlUp).Row Step 12
Set Rng2 = Union(Rng2, Rng2.Offset(i, 0))
Next i

Rng2.Copy mySht.Cells(myStartRow, 3)

End With

With Sheets("Ingredient Products")
.Columns("B:B").AutoFit
.Columns("C:G").NumberFormat = "#,##0.00"
.Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Range("A1").Select
End With
End Sub

 

[John]

Thanks Bernie

John,

Try the code below to see if it improves your results.

HTH,
Bernie
MS Excel MVP

Sub TradeupCostToIngredients_Post2()
Dim i As Long
Dim myStartRow As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim mySht As Worksheet

Set mySht = Worksheets("Ingredient Products")

myStartRow = mySht.Cells(mySht.Rows.Count, 1).End(xlUp)(2).Row

With Worksheets("Trade Up Meals")
Set Rng1 = Union(.Range("A9"), .Range("B9"))
Set Rng2 = Union(.Range("J18"), .Range("K18"), _
.Range("L18"), .Range("N18"), .Range("O18"))

For i = 0 To .Range("A65536").End(xlUp).Row Step 12
Set Rng1 = Union(Rng1, Rng1.Offset(i, 0))
Next i

Rng1.Copy mySht.Cells(myStartRow, 1)

For i = 0 To .Range("A65536").End(xlUp).Row Step 12
Set Rng2 = Union(Rng2, Rng2.Offset(i, 0))
Next i

Rng2.Copy mySht.Cells(myStartRow, 3)

End With

With Sheets("Ingredient Products")
.Columns("B:B").AutoFit
.Columns("C:G").NumberFormat = "#,##0.00"
.Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Range("A1").Select
End With
End Sub

"A").End(xlUp).Row,