Search code examples
excelvbaunpivot

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

I need to use data from one sheet to fill in another sheet in the same workbook.
enter image description here

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
Solution

  • 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