Copy and paste range of data to next available row on different sheet

[Trae1170]

Hello everyone, I have a problem that hopefully one of you smart people can help me with.
I have a spreadsheet that is used for a "Action Tracker" (1st screenshot). In column F, if I choose from the dropdown and place a checkmark in the box, I would like the data in cells G, H, I and J to be copied and pasted into the next available row on a different sheet (screenshot 2) starting on A19, H19, J19 & L19.

Right now I have it directly transferring using a formula which works but if I have any rows on the first sheet that are not checked, then I have a gap in the data on the second sheet. I want VBA code so that whenever a checkmark is placed the data transfers to the next available row so there is no gaps.

The 2nd part, maybe not as easy would be if I "Unchecked" a box on the first sheet it would remove the data from the second sheet and automatically shift all of the data up to the next available row. This would be to continue to prevent any empty rows on the second sheet.

I am using Office360, I can provide the workbook if needed.

 

[NoSparks]

Only reply to your previous post of something very similar was from you

Hello Everyone, does anyone want to try to attempt this one?

With this request here it appears things have morphed somewhat.
If you make your sheets available with either Mr Excels xl2bb add-in or
by sharing a workbook, I'll have a go at it.

 

[Trae1170]

Only reply to your previous post of something very similar was from you


With this request here it appears things have morphed somewhat.
If you make your sheets available with either Mr Excels xl2bb add-in or
by sharing a workbook, I'll have a go at it.

How can I send you my workbook?

 

[Trae1170]

Only reply to your previous post of something very similar was from you


With this request here it appears things have morphed somewhat.
If you make your sheets available with either Mr Excels xl2bb add-in or
by sharing a workbook, I'll have a go at it.

I just sent you a PM

 

[NoSparks]

Sorry Trae, was really hoping I could help with this but I'm afraid not.

Hopefully you'll be able to reduce the file down to just what you're asking about and make it available to everyone.
I'm sure someone will come up with a solution then.

Good Luck

 

[Trae1170]

Just so I understand, why can you not help? Is it my spreadsheet? I am not sure what you mean by " reduce the file down to just what you're asking about"??

 

[NoSparks]

OK, I can help you to the point of writing the Action Item Tracker info to the Actions Escalation area of the Summary Report when YES gets selected in column F,
and removal from the Summary Report when YES is removed from the column F cell by including the Action # on the Summary Report (in column M) to keep track of which record is which.

Currently I'm unable to come up with something to eliminate the blank rows in the Action Escalation area that maintains the range size, formatting and (dreaded) merged cells.

For what it's worth, have altered what you have in module 19 and added it to the Action Item Tracker Worksheet_Change event that you have to RefreshAll.
Maybe this will be of some use but without the removal of the blank rows not sure.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsAction As Worksheet
    Dim wsSummary As Worksheet
    Dim nextRow As Long
    Dim actionRow As Long, i As Long, fndAction As Range
        
    Set wsAction = ThisWorkbook.Sheets("Action Item Tracker")
    Set wsSummary = ThisWorkbook.Sheets("Summary Report")

    ' limit to a single cell
    If Target.CountLarge > 1 Then Exit Sub
    ' in col F, rows 4 thru 497
    If Target.Column = 6 And Target.Row >= 4 And Target.Row <= 497 Then
        actionNum = Range("A" & Target.Row).Value   ' record identity

        If Target.Value = "YES" Then
            With wsSummary
                nextRow = .Range("A35").End(xlUp).Row + 1
                If nextRow < 19 Then nextRow = 19 ' Ensure we start at least at row 19
                If nextRow = 35 Then
                    MsgBox "The Report Area is full" & vbCrLf & "Will not exit sub"
                    Exit Sub
                End If
                .Range("A" & nextRow) = Target.Offset(, 1)          ' Action Description
                .Range("G" & nextRow).Value = Target.Offset(, 2)    ' Organizational Owner
                .Range("H" & nextRow).Value = Target.Offset(, 3)    ' Department Owner
                .Range("J" & nextRow).Value = Target.Offset(, 5)    ' Assigned To (owner)
                .Range("L" & nextRow).Value = Target.Offset(, 4)    ' Required / Need Date
                .Range("M" & nextRow).Value = actionNum
            End With
        Else
            With wsSummary
' Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
                Set fndAction = .Range("M19:M34").Find(actionNum)
                If Not fndAction Is Nothing Then
                    .Range("A" & fndAction.Row).Resize(, 13).ClearContents
                End If
                
                ' code required here to eliminate blank rows from row 19 thru 34
                
            End With
        End If
    End If
    
Application.EnableEvents = False
  ThisWorkbook.RefreshAll
Application.EnableEvents = True

End Sub

You will need to disable events in any other macros that alter cells on the Action Item Tracker sheet.

Sorry I can't help more.

 

[Trae1170]

Thank you so much for helping out. Hopefully I can get it finished

 

[NoSparks]

Hopefully I can get it finished

Decided to take on 'the missing piece' as a learning experience.

After all day googling and testing everything found,
deep down in one of the search returns was a thread where I adapted JoeMo's post #5 code and came up with this

Sub RemoveBlankRows()

    Dim DataRng As Range, arr As Variant
    Dim Ct As Long, i As Long
    Dim DataSH As Worksheet, DataTarget As Range
    
Set DataSH = Sheets("Summary Report")
Set DataRng = DataSH.Range("A19:M34")

ReDim arr(1 To DataRng.Columns.Count)

For i = 1 To DataRng.Rows.Count
    If DataRng.Cells(i, 1) <> "" Then
        Ct = Ct + 1
        arr(Ct) = Application.Index(DataRng, i, 0).Value
    End If
Next i

' now have non-blanks in arr, write them to sheet
    
If Ct > 0 Then
    DataRng.ClearContents
    For i = 1 To Ct
        Set DataTarget = DataSH.Range("A19").Offset(i - 1, 0).Resize(1, UBound(arr))
        DataTarget.Value = arr(i)
    Next i
End If

End Sub

Put the above code in a standard module
and call it from within the Action Item Tracker Worksheet_Change event

            With wsSummary
                Set fndAction = .Range("M19:M34").Find(actionNum)
                If Not fndAction Is Nothing Then
                    .Range("A" & fndAction.Row).Resize(, 13).ClearContents
                End If
                
                ' code required here to eliminate blank rows from row 19 thru 34
                Call RemoveBlankRows
                
            End With

Hope that helps towards finishing the project.

 

[NoSparks]

upon further testing...
in the Worksheet_Change event, change this line

     Set fndAction = .Range("M19:M34").Find(actionNum)

to

     Set fndAction = .Range("M19:M34").Find(What:=actionNum, LookIn:=xlValues, Lookat:=xlWhole)

the Lookat can be either xlPart or xlWhole and is persistent, if not specified whatever was last used is used again.