copy entire row to a new sheet and change cell value based on cell value-CodePudding

Is someone able to help? I have an existing code which currently copies entire rows of data from one sheet (Quality Log) to another sheet(Appeal Log) based off of a cell value(Appeal Logged) in a Column V.

Previously it has deleted that row from the originating (Quality Log) sheet but I'm now looking to change the code so that it changes the cell value to (Under Appeal) and then moves it to the next sheet (Appeal Log).

Please see my code below. i have indicated with a ** my attempt to alter the code

    Dim xRg As Range
    Dim xCell As Range
    Dim i As Long
    Dim j As Long
    Dim K As Long
    i = Worksheets("Quality Log").UsedRange.Rows.Count
    j = Worksheets("Appeal Log").UsedRange.Rows.Count
    If j = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Actioned").UsedRange) = 0 Then j = 0
    End If
    Set xRg = Worksheets("Quality Log").Range("V3:I" & i)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Appeal Logged" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Appeal Log").Range("A" & j   1)
            **xRg(K, 22).Value = "Under Appeal"**
            
            'xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Appeal Logged" Then
                K = K - 1
            End If
            j = j   1
        End If
    Next
   
'Call ResizeArchiveTable
      
    Application.ScreenUpdating = True
End Sub```



Any and all help is much appreciated.

CodePudding user response：

Flag and Copy Rows

Sub CopyData()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Quality Log")
    Dim slRow As Long: slRow = sws.UsedRange.Rows.Count
    Dim srg As Range: Set srg = sws.Range("V3:V" & slRow)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Appeal Log")
    Dim dlRow As Long: dlRow = dws.UsedRange.Rows.Count
    Dim drrg As Range: Set drrg = dws.Rows(dlRow)
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    Dim drCount As Long
    
    For Each sCell In srg.Cells
        If CStr(sCell.Value) = "Appeal Logged" Then
            sCell.Value = "Under Appeal"
            drCount = drCount   1
            sCell.EntireRow.Copy drrg.Offset(drCount)
        End If
    Next sCell
    
    Application.ScreenUpdating = True

    MsgBox "Rows copied: " & drCount, vbInformation

End Sub