คัดลอกเซลล์ไปยังชีตอื่นและแทรกแถวสำหรับเซลล์ที่คัดลอก

ฉันกำลังพยายามสร้างส่วนย่อยที่คัดลอกข้อมูลจากฟอร์มหนึ่ง (ซึ่งมีสี่เซลล์) ไปยังชีตอื่น

• เมื่อมันคัดลอกข้อมูลก็จะสร้างแถวใหม่
• แต่ละแบบฟอร์มมีจำนวนแถวสูงสุดได้สิบแถว แต่ควรสามารถรับรู้ได้เมื่อแบบฟอร์มมีเซลล์ว่างและหยุด
• มันควรจะง่ายต่อการทำซ้ำในรูปแบบอื่น ๆ

ตัวอย่างของแบบฟอร์มสามารถเห็นได้โดยใช้ลิงค์ด้านล่าง

นี่คือรหัสของฉันซึ่งใช้งานไม่ได้

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

นี่จะเป็นการหลอกลวง:

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