Copiando células para outra planilha e inserindo linhas para as células copiadas

Question

Estou tentando criar um sub que copie informações de um formulário (que tem quatro células) para outra.

• Quando copia as informações, também cria uma nova linha.
• Cada formulário tem um máximo de dez linhas, mas deve poder reconhecer quando um formulário tem células vazias e parar.
• Também deve ser fácil replicar para outras formas.

Uma amostra dos formulários pode ser vista usando o link abaixo.

Aquiestáomeucódigoquenãofunciona

SubUpdate_1()DimlastrowAsLong,erowAsLonglastrow=Sheet1.Cells(Rows.Count,1).End(xlUp).RowFori=lastrowTo3Sheet1.Cells(i,1).Copyerow=Sheet2.Cells(Rows.Count,1).End(xlUp).Offset(1,0).RowSheet1.PasteDestination:=Sheet2.Cells(erow,2)Sheet1.Cells(i,2).CopySheet1.PasteDestination:=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 1

Isso fará o truque:

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