For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

**unit285** · 07-14-2017, 01:37 PM

Hello,
This code has me all sorts of frustrated. It seems like it should work to me but it's not.

So what I want to accomplish is to move data from the mod sheet to the Final Sheet. Specifically, Columns (B:D) data on each populated row in the mod sheet. So for example, currently, the value in mod sheet B2 should move to the Final Sheet A2, the value in mod sheet C2 should move to the Final Sheet A3, and the value in mod sheet D2 should move to the Final Sheet A4, Then it should move to mod sheet row 3 and repeat and on and on.
My code is posted below, Any help is greatly appreciated!

Private Sub cb_Click()
Dim MyCell As Variant, modLR As Integer, FinalLR As Integer, MyRange As Range
On Error Resume Next
ActiveWorkbook.Names("MyRange").Delete
On Error GoTo 0
modLR = Sheets("mod").Range("A" & Rows.Count).End(xlUp).Row
FinalLR = Sheets("Final").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("mod").Range("$A$2:$A" & modLR).Name = "MyRange"
For Each MyCell In Sheets("mod").Range("MyRange")
Sheets("Final").Range("$A$2:$A$" & FinalLR).Value = MyCell.Offset(0, 1).Value
Sheets("Final").Range("$A$2:$A$" & FinalLR + 1).Value = MyCell.Offset(0, 2).Value
Sheets("Final").Range("$A$2:$A$" & FinalLR + 2).Value = MyCell.Offset(0, 3).Value
FinalLR = FinalLR + 2
Next MyCell
End Sub

**xladept** · 07-14-2017, 01:56 PM

Just a small change:

Private Sub cb_Click()
Dim MyCell As Variant, modLR As Integer, FinalLR As Integer, MyRange As Range
On Error Resume Next
ActiveWorkbook.Names("MyRange").Delete
On Error GoTo 0
modLR = Sheets("mod").Range("A" & Rows.Count).End(xlUp).Row
FinalLR = Sheets("Final").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("mod").Range("$A$2:$A" & modLR).Name = "MyRange"
For Each MyCell In Sheets("mod").Range("MyRange")
Sheets("Final").Range("A" & FinalLR).Value = MyCell.Offset(0, 1).Value
Sheets("Final").Range("A" & FinalLR + 1).Value = MyCell.Offset(0, 2).Value
Sheets("Final").Range("A" & FinalLR + 2).Value = MyCell.Offset(0, 3).Value
FinalLR = FinalLR + 2
Next MyCell
End Sub

**CK76** · 07-14-2017, 02:01 PM

Your code as it's written will replace entire range's value each time.

My preference is to use array to do operation in memory and commit to cell in 1 shot.

Private Sub cb_Click()
Dim tempArr, resArr
Dim i As Long, j As Long
tempArr = Sheets("Mod").Range("B2:D" & Sheets("Mod").Cells(Rows.Count, "B").End(xlUp).Row).Value
ReDim resArr(1 To UBound(tempArr, 1) * 3, 1)

For i = 1 To UBound(resArr, 1) Step 3
    j = Application.RoundUp(i / 3, 0)
    resArr(i, 0) = tempArr(j, 1)
    resArr(i + 1, 0) = tempArr(j, 2)
    resArr(i + 2, 0) = tempArr(j, 3)
Next
Sheets("Final").Range("A2").Resize(UBound(resArr, 1)) = resArr
End Sub

**xladept** · 07-14-2017, 03:07 PM

You're welcome and thanks for the rep!

For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

Re: For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

Re: For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

Re: For Loop to move Rows(B:D) Data to Single Column Consecutively. Code not working.

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Copy each row consecutively into one single column preserving formulas

[SOLVED] Macros To Move Multiple Rows To Another Sheet And Macro To Move Single Rows To DAX Table

Need VBA Code To Combile Data from Different Columns to Single Column for multiple rows

Selection of loop data, move copy and paste data, and exclude blank rows

How do i move like data in columns to single rows?

Code not working - move rows when cell is less than zero

Loop though rows and move data

Bookmarks

Bookmarks

Posting Permissions