Beginner learning VBA... I need my code to do a specific task which is 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 over to Sheet2 and any relevant information will be copied over as well. Then Column D's item will be copied over 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

CodePudding user response：

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

CodePudding user response：

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

CodePudding user response：

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