Loop rows to copy from one sheet's columns to another sheet - excel

Question

I need to use data from one sheet to fill in another sheet in the same workbook.
Using sheet1's data:
Column C's item will be copied to Sheet2 and any relevant information will be copied over as well.
Then Column D's item will be copied to the next row with its relevant information.
This will be repeated until all rows in Sheet1 are copied over to Sheet2.
(Note: I put this macro as a button in another sheet so I'm referencing each sheet in my code.)
NumRows = Worksheets("Sheet1").Range("C2", Range("C2").End(xlDown)).Rows.Count
' Select cell, *first line of data*.
Worksheets("Sheet1").Range("C2").Select
' Set Do loop to stop when ten consecutive empty cells are reached. (Make sure it's safely run; ignore)
j = 4
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(10, 0))
For i = 2 To NumRows
j = j + 1
Worksheets("Sheet1").Cells(i, "C").Value = Worksheets("Sheet2").Cells(j, "C").Value
Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
' New row for next item
j = j + 1
Worksheets("Sheet1").Cells(i, "D").Value = Worksheets("Sheet2").Cells(j, "C").Value
Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Next
Loop
Application.ScreenUpdating = True
End Sub

Answer 1

Your code is copying from sheet2 to sheet1.
Option Explicit
Sub Macro1()
Dim j As Long, i As Long, c As Long
Dim ws2 As Worksheet, lastrow As Long
Set ws2 = Sheets("Sheet2")
j = 1
Application.ScreenUpdating = False
With Sheets("Sheet1")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastrow
For c = 3 To 4
If Len(.Cells(i, c)) > 0 Then
j = j + 1
ws2.Cells(j, "A") = .Cells(i, "A")
ws2.Cells(j, "B") = .Cells(i, "B")
ws2.Cells(j, "C") = .Cells(i, c)
ws2.Cells(j, "D") = .Cells(i, "E")
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox j-1 & " rows copied", vbInformation
End Sub

Answer 2

Unpivot Data
The title says it all: it's a job for Power Query. Yet, here's my stab at VBA.
Option Explicit
Sub UnpivotData()
Const ProcTitle As String = "Unpivot Data"
Const sName As String = "Sheet1"
Dim ssCols As Variant: ssCols = VBA.Array(1, 2, 5)
Dim smCols As Variant: smCols = VBA.Array(3, 4)
Const dName As String = "Sheet2"
Const dFirst As String = "A2"
Dim dsCols As Variant: dsCols = VBA.Array(1, 2, 4)
Const dmCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = strg.Rows.Count - 1 ' no headers
Dim sdrg As Range: Set sdrg = strg.Resize(srCount).Offset(1)
Dim sdData As Variant: sdData = sdrg.Value
Dim drCount As Long: drCount = srCount * (UBound(smCols) + 1)
Dim dcCount As Long: dcCount = UBound(dsCols) + 2
Dim ddData As Variant: ReDim ddData(1 To drCount, 1 To dcCount)
Dim sdValue As Variant
Dim sr As Long
Dim sc As Long
Dim c As Long
Dim dr As Long
For sr = 1 To srCount
For sc = 0 To UBound(smCols)
sdValue = sdData(sr, smCols(sc))
If Not IsError(sdValue) Then
If Len(CStr(sdValue)) > 0 Then
dr = dr + 1
ddData(dr, dmCol) = sdValue
For c = 0 To UBound(ssCols)
ddData(dr, dsCols(c)) = sdData(sr, ssCols(c))
Next c
'Else ' blank value
End If
'Else ' error value
End If
Next sc
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim ddrg As Range: Set ddrg = dfCell.Resize(dr, dcCount)
ddrg.Value = ddData
MsgBox "Data copied.", vbInformation, ProcTitle
End Sub

Answer 3

I believe you wanna copy data from sheet1 to sheet2 down the line of sheet to data, not sure about asking overriding the data on sheet to, we can create script without looping, please find below if it is helpful.
Sub Copydata()
Dim I As Long
Sheet1.Select
I = Range("C10000").End(xlUp).Row
Range("C2:C" & I).Select
Range(Selection, Selection.End(xlToRight)).Copy
Sheet2.Select
Range("C10000").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial
End Sub