将整行复制到新工作表并根据单元格值更改单元格值

Question

我有一个代码，它将一整行数据从一个表(质量日志)复制到另一个表(上诉日志)基于一个单元格值(上诉日志)在列v

先前已从原始(质量日志)表中删除了这一行。

我现在希望将单元格值更改为(上诉下)，然后将其移动到下一个工作表(上诉日志)。

我用**表示我试图修改代码。

Sub CopyToAppealLog()
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

Answer 1

标记和复制行

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