adding data to rows in different columns

[jaycee]

Hi,

My worksheet does varying things which I have managed to get to work well.

My only issue is getting the correct data into the correct amount of rows, I have managed to get the first 2 columns correct but then populating another column with data from a userform and adding the date is what I need to do.

The first 2 columns are copied from sheet 1 with the amount required from a userrform, I need the same amount added to this data in sheet 2.

Private Sub CmdEnter_Click()
    Dim arr()   As Variant
    Dim wks     As Worksheet
    Dim x       As Long
    
    Application.ScreenUpdating = False
    
    'Set up input box
    On Error Resume Next
    x = FrmCards.TxtNo.Value
    
    'Copy Rows
    If x > 0 Then
        With Sheets("Sheet1").Cells(2, 1).Resize(x, 2)
            arr = .Value
            .EntireRow.Delete shift:=xlUp
        End With
    Else
        MsgBox "Invalid input!" & vbCrLf & vblcrf & "Please try again", vbExclamation, "Invalid Input"
        Exit Sub
    End If
    Set wks = Sheets("Sheet2")
    On Error GoTo 0
            
    'Paste rows into sheet 2
    If wks Is Nothing Then
        Set wks = Sheets.Add(after:=Sheets(Sheets.Count))
        With wks
            .Name = "Sheet2"
            .Cells(1, 1).Resize(, 2).Value = Sheets("Sheet1").Cells(1, 1).Resize(, 2).Value
        End With
    End If
    With wks
[SIZE=3][COLOR=#0000FF]        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr[/COLOR][/SIZE]
       [SIZE=4][FONT=arial black][COLOR=#FF0000] .Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = FrmCards.TxtRemedy.Value
        .Cells(Rows.Count, 4).End(xlUp).Offset(1).Value = Now()[/COLOR][/FONT][/SIZE]
        End With
    'Paste rows into sheet 3
    Sheets("sheet3").Select
    Set wks = Sheets("Sheet3")
        With wks
           .Cells(1, 1).Resize(, 2).Value = Sheets("Sheet1").Cells(1, 1).Resize(, 2).Value
        End With
    wks.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
    'Copy Sheet 3 to new workbook & delete data in sheet 3
    New_Sheet
    Application.ScreenUpdating = True
End With
End Sub

It is the 2 rows in red that I have an issue with, I need them to be the same size as the row in Blue, but not sure how this can be done

 

[Fluff]

Try

.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(x).Value = FrmCards.TxtRemedy.Value
.Cells(Rows.Count, 9).End(xlUp).Offset(1).Resize(x).Value = Now()

 

[jaycee]

Brilliant,

Thanks very much

 

[Fluff]

Your welcome & thanks for the feedback

 

[sharmidevi]

Thank you