move Items from a table to another sheet VBA-CodePudding

I have this code that moves data from one sheet to another sheet for records keeping purposes but I need the ID# to fill the along with the rest of the items for example

Currently the code output it like this

and this is where the source data will be

    Sub Button4_Click()
'Create and set variables for the Call Tracking & Call Log worksheets
Dim Form As Worksheet, DB As Worksheet

Set Form = Sheet1
Set DB = Sheet2


'Create and set variables for each cell in the call tracking sheet
Dim IDNum As Range, Item As Range, QTY As Range

Set IDNum = Form.Range("C9:D9")
Set Item = Form.Range("C11")
Set QTY = Form.Range("C13")


'Create a variable for the paste cell in the Call Log worksheet
Dim DestCell As Range

If DB.Range("A2") = "" Then 'If A2 is empty
    Set DestCell = DB.Range("A2") '...then destination cell is A2
Else
    Set DestCell = DB.Range("A1").End(xlDown).Offset(1, 0) '...otherwise the next empty row
End If

'If no "Number called has been entered, exit macro
If IDNum = "" Then
    MsgBox "You must enter an ID#"
    Exit Sub
End If

'Copy and paste data from the Call Tracking worksheet to the Call Log worksheet
IDNum.Copy DestCell
Item.Copy DestCell.Offset(0, 1)
Country.Copy DestCell.Offset(0, 2)
QTY.Copy DestCell.Offset(0, 3)

Call Macro1
'Clear the contents in the Call Tracking worksheet
End Sub

CodePudding user response：

Try something like this (check the ranges are correct):

Sub Button4_Click()
    
    Dim Form As Worksheet, DB As Worksheet
    Dim rw As Range, DestCell As Range, IDNum
    
    Set Form = Sheet1
    Set DB = Sheet2
    
    IDNum = Trim(Form.Range("C9").Value) 'useful to Trim user inputs...
    If Len(IDNum) = 0 Then
        MsgBox "You must enter an ID#"
        Exit Sub
    End If
    
    'next empty cell in ColA
    Set DestCell = DB.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
    Set rw = Form.Range("B20:D20") 'first row of items
    Do While Application.CountA(rw) > 0   'while source row has content
        DestCell.Value = IDNum            'write the id
        DestCell.Offset(0, 1).Resize(1, rw.Cells.Count).Value = rw.Value 'transfer values
        Set rw = rw.Offset(1)             'next source row
        Set DestCell = DestCell.Offset(1) 'next paste
    Loop
    
    Call Macro1 'Clear the contents in the Call Tracking worksheet
    
End Sub

Note you can change the sheet codenames for Sheet1 and Sheet2 to Form and DB respectively, then you can skip the worksheet declarations.