Copy a row to new ws when condition is met on source worksheet

[Frank Bacchus]

I have a workbook with two spreadsheets (1) Current Issues (2) Closed Issues I would like to automatically copy data from the Current Issues spreadsheet and append to the Closed Issues spreadsheet when the issue is closed. The ‘Status’ cell (D) will indicate “Closed”. I do not want to copy the entire row from the Current Issues spreadsheet, just certain cells. Once the copy is completed, I want to delete that row from the Current Issues spreadsheet. The cells I want to copy are as follows:

SEQ - Yes

Submitter - Yes

Title - Yes

Status - Yes

Create Date - Yes

L(arge) S(mall) C- Yes

Assigned To - Yes

Date Assigned - Yes

Days Open - Yes

Date Completed - Yes

Validation No

Row - No

7/28/2017 – No


Test file is included, Can you help?

 

[SirJB7]

Hi, Frank Bacchus!

Give a look at the uploaded file. This is the VBA code for worksheet Issues object:

Option Explicit

' global constants
Const gkiFilter = 4
Const gksFilter = "Completed"

Private Sub Worksheet_Change(ByVal Target As Range)
    ' constants
    ' declarations
    ' start
    With Target
        If .Cells.Count > 1 Or .Column <> gkiFilter Then Exit Sub
    End With
    Application.EnableEvents = False
    ' process
    If CStr(Target.Value) = gksFilter Then GoToBAndHPhotoVideoAndGiveMeACall Target
    ' end
    Application.EnableEvents = True
End Sub

Private Sub GoToBAndHPhotoVideoAndGiveMeACall(pr As Range)
    '
    ' constants
    Const ksWSSource = "Issues"
    Const ksRngSource = "IssuesCropTable"
    Const ksWSTarget = "Closed Issues"
    Const ksRngTarget = "ClosedIssuesTable"
    '
    ' declarations
    Dim wS As Worksheet, rS As Range, wT As Worksheet, rT As Range
    Dim I As Integer, J As Long, K As Long
    '
    ' start
    '  ws & ranges
    Set wS = Worksheets(ksWSSource)
    Set rS = wS.Range(ksRngSource)
    Set wT = Worksheets(ksWSTarget)
    Set rT = wT.Range(ksRngTarget)
    '
    ' process
    With rS
        I = MsgBox("Finished editing record for:" & vbCr & vbCr & _
                    .Cells(1, 1).Value & ": " & pr.Offset(0, 1 - pr.Column).Value & vbCr & _
                    .Cells(1, 2).Value & ": " & pr.Offset(0, 2 - pr.Column).Value & vbCr & vbCr & _
                    "If 'Yes' record will be removed from Issues and moved to Closed Issues." & vbCr & vbCr & _
                    "Proceed?", vbQuestion + vbYesNo, "Confirmation")
    End With
    If I = vbYes Then
        ' target row
        J = rT.Rows(rT.Rows.Count).End(xlDown).End(xlDown).End(xlUp).Row + 1
        ' source row
        K = pr.Row - rS.Row + 1
        ' copy
        Range(rS.Cells(K, 1), rS.Cells(K, 10)).Copy rT.Cells(J, 1)
        ' delete
        wS.Rows(pr.Row).Delete xlShiftUp
        '
        MsgBox "Record re/moved", vbOKOnly + vbInformation, "Done"
    Else
        '
        MsgBox "Nothing done", vbOKOnly + vbInformation, "Cancellation"
    End If
    '
    ' end
    '  ws
    Set wS = Nothing
    Set rS = Nothing
    Set wT = Nothing
    Set rT = Nothing
    '
End Sub

BTW, next time upload a workbook with no #REF# errors specially in involved columns, testing with a file like that makes it very hard to test anything.

Regards!

 

[Frank Bacchus]

SirJB7:

Thanks for the response and sorry for my delay response to you and my gratitude. I was away and just returned. I will run this code and confirm with you later. Thanks alot.

frank