Copying cells to another sheet and inserting rows for the copied cells

Posted on

QUESTION :

I am trying to create a sub that copies information from one form (which has four cells) to another sheet.

  • When it copies the information it also creates a new row.
  • Each form has a maximum of ten rows but it should be able to
    recognize when a form has empty cells and stop.
  • It should also be easy to replicate to other forms.

A sample of the forms can be seen using the link below.

enter image description here

Here is my code which does not work

Sub Update_1()

Dim lastrow As Long, erow As Long

lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 3
    Sheet1.Cells(i, 1).Copy
    erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Sheet1.Paste Destination:=Sheet2.Cells(erow, 2)

    Sheet1.Cells(i, 2).Copy
    Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 1)

    Sheet1.Cells(i, 3).Copy
    Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 8)

    Sheet1.Cells(i, 4).Copy
    Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)

    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Sheet1").Select
    Next i
End sub

ANSWER :

This will do the trick:

Public Sub allergy_copy()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wks1 As Worksheet
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    Set wks1 = wkb.Sheets(2)
    endrows = False
    thisrow = 3
    While endrows = False
        If wks.Cells(thisrow, 1) <> "" Then
            With wks
                .Rows(thisrow).Copy Destination:=wks1.Rows(thisrow)
                thisrow = thisrow + 1
            End With
        Else
            endrows = True
        End If
    Wend
End Sub

Leave a Reply

Your email address will not be published.