Copying data to a specific location, not last available empty row

[RoyLittle0]

Hi, I am quite new to VBA and coding so please bear with me on this one.

I am using the following code to insert a row of data in an Excel sheet (Sheet 1 RAMS) from another sheet in the same workbook (Sheet 2 Risks), this copy is based on a Selection box in (Sheet 2 Risks), all works as it should and the data is populated into (Sheet 1 RAMS) in the next available empty cell in Column A – All good so far.

The (Sheet 1 RAMS) is a user form and will contain other data as well as the data being inserted from (Sheet 2 Risks) which is a master database, I have approximately 60 entries in (Sheet 2 Risks) and I am using the range B:H to copy over.

As (Sheet 1 RAMS) is a user form it will have data and formatting to it, it will not be a blank form, it will have an area to insert the data, preferably one row and then adding the data will also insert a second line and move everything below it down a row.

So, I have data in rows A1:A20 and A22:A120, can I insert the line of data into A21 and then insert a blank line A21, which moves A22:A120 down to A23:A121
When the Selection box is selected it inserts the contents into (Sheet 1 RAMS) but if it is subsequently de-selected it will remove it, delete it from (Sheet 1 RAMS)
I have tried a few different things like Rows("1:21") Range("1:21") but get an error or simply doesn’t work, so I am at a bit of a loss at the moment.


Sub CheckboxClicked()
Dim cel As Range, dest As Range, rw As Range, targ As Range
Set cel = ActiveSheet.Shapes(Application.Caller).TopLeftCell
Set rw = Intersect(cel.EntireRow, Range("B:H")) 'This is the number of columns to be coppied over to the RAMs work sheet
'This is the destination and offset based on cell A1

With Worksheets("RAMS")
Set dest = .Columns("A").Find(Application.Caller)
If dest Is Nothing Then
If cel.Value = True Then
Set dest = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
dest.Offset(0, 1).Resize(1, rw.Columns.Count).Value = rw.Value
'dest.Offset(0, rw.Columns.Count + 1).Value = Now 'Adds the date and time that the RAMS were added (Commented out)
dest.Value = Application.Caller
End If
Else
If cel.Value = False Then dest.EntireRow.Delete
End If
End With
End Sub

[mana]

Option Explicit


Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim m
Dim n As Long

m = Application.Match("Persons on site", Columns("A"), 0) - 22

If m > 0 Then Rows(22).Resize(m).Delete

Set ws = Worksheets("Risks")

With ws.Range("A1").CurrentRegion
.AutoFilter
.AutoFilter 1, True
n = .Columns("A").SpecialCells(xlCellTypeVisible).Count - 1
If n > 0 Then
Rows(22).Resize(n).Insert
.Offset(1).Columns("B:H").Copy Range("B21")
End If
.AutoFilter
End With
End Sub

[RoyLittle0]

Mana, I have added the above code to my form but it has no effect to the placement of data, it is still inserted to the last available row in the form, so in the RAMS Test.xlsm it puts the data into A29.

[mana]

Sheet module
(Not Standard module)


Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim m
Dim n As Long

m = Application.Match("Persons on site", Columns("A"), 0) - 22
If m > 0 Then Rows(21).Resize(m).Delete

Set ws = Worksheets("Risks")

With ws.Range("A1").CurrentRegion
.AutoFilter
.Parent.Columns("B").Insert
.Columns("B").Formula = "=""Risk""&ROW()"
.Columns("B").Value = .Columns("B").Value
.AutoFilter 1, True
n = .Columns("A").SpecialCells(xlCellTypeVisible).Count - 1
If n > 0 Then
Rows(22).Resize(n).Insert
.Offset(1).Columns("B:I").Copy Range("A21")
End If
.AutoFilter
.Parent.Columns("B").Delete
End With

End Sub

[NoSparks]

Does this do what you're looking for ?


Sub CheckboxClicked()
Dim cel As Range, dest As Range, rw As Range, targ As Range
Set cel = ActiveSheet.Shapes(Application.Caller).TopLeftCell
Set rw = Intersect(cel.EntireRow, Range("B:H")) 'This is the number of columns to be coppied over to the RAMs work sheet
'This is the destination and offset based on cell A1

With Worksheets("RAMS")
Set dest = .Columns("A").Find(Application.Caller)
If dest Is Nothing Then
If cel.Value = True Then
'insert a new row 21
.Rows(22).Insert
'destination is always A22
Set dest = .Range("A22")
'write to cells
dest.Offset(0, 1).Resize(1, rw.Columns.Count).Value = rw.Value
'set row height
dest.EntireRow.AutoFit
'dest.Offset(0, rw.Columns.Count + 1).Value = Now 'Adds the date and time that the RAMS were added (Commented out)
dest.Value = Application.Caller
End If
Else
'remove if unchecked
If cel.Value = False Then dest.EntireRow.Delete
End If
End With
End Sub

[RoyLittle0]

Does this do what you're looking for ?

It most certainly does NoSparks, That's exactly what I was after, Works like I wanted, Many Thanks

[NoSparks]

You're welcome, glad to have helped.