将特定单元格 Excel 复制到另一张工作表，并删除条件格式和数据验证

Question

需要运行一个工作表，并将所有标记为“发送给客户”或“可发送”的内容的 A 列到 F 列复制到另一个工作表中，然后从第一个工作表中删除整行。 我当前使用的版本可以正常工作，但会复制整行，但第二张工作表不需要单元格 G 到 J，因为这些列中的数据不同。

此外，第一张纸上的条件格式和数据验证与第二张纸无关，但会在此过程中复制。

我一直在使用的代码是这样的：

Sub MoveToClientShipping()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetRow As Long
    ' Case sensitivity is a bitch.
    With Range("D1", Cells(Rows.Count, "D").End(xlUp))
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
   
    ' Set the source and target sheets
    Set sourceSheet = ThisWorkbook.Worksheets("Model Storage List")
    Set targetSheet = ThisWorkbook.Worksheets("Client Ship List")

    ' Find the last row in the source sheet
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    ' Find the first row in the target sheet | This line might be redundant, but I'm afraid to remove it.
    Set startrow = targetSheet.Range("A6")
    ' Find the next empty cell in column A on the target sheet
    NextFree = targetSheet.Range("A2:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    Range("A" & NextFree).Select
    ' Last row in column D on the target sheet
    targetRow = targetSheet.Cells(targetSheet.Rows.Count, "D").End(xlUp).Row
    ' Loop through each row in the source sheet
    For i = lastRow To 1 Step -1
    ' Check if cell in column D contains "Sendable"
    If sourceSheet.Cells(i, "D").Value = "Sendable" Then
            ' Increment target row
            targetRow = targetRow + 1
            ' Copy the entire row to the target sheet
            sourceSheet.Rows(i).Copy Destination:=targetSheet.Cells(targetRow, 1)
            ' Delete the row from the source sheet
            sourceSheet.Rows(i).Delete
        End If
    ' Check if cell in column D contains "Sent To Client"
    If sourceSheet.Cells(i, "D").Value = "Sent To Client" Then
            ' Increment target row
            targetRow = targetRow + 1
            ' Copy the entire row to the target sheet
            sourceSheet.Rows(i).Copy Destination:=targetSheet.Cells(targetRow, 1)
            ' Delete the row from the source sheet
            sourceSheet.Rows(i).Delete

    Next i
    
    MsgBox ("Client Ship List Populated | Please fill in missing criteria.")
        
End Sub

我尝试修改在搜索中找到的此块以删除单元格，但它删除了第二张表的 G 到 J 列中的所有现有数据（这是有道理的，考虑到它的字面意思是“EntireColumn.Delete”）。

 For i = rgOut.Columns.count To 1 Step -1
 Select Case i
 Case 1, 6
 Case Else
 rgOut.Columns(i).EntireColumn.Delete
 End Select
 Next i

Answer 1

考虑更改循环代码，如下所示：

For i = lastRow To 1 Step -1
' Check if cell in column D contains "Sendable" or "Sent To Client"
    Select Case SourceSheet.Cells(i, "D").Value
        Case "Sendable", "Sent To Client"
            ' Increment target row
            targetRow = targetRow + 1
            ' Copy columns A:F to the target sheet
            SourceSheet.Range("A" & i & ":F" & i).Copy Destination:=targetSheet.Cells(targetRow, 1)
            ' Delete the row from the source sheet
            SourceSheet.Rows(i).Delete
            With targetSheet.Cells(targetRow, 1).Resize(, 6)
                .FormatConditions.Delete
                .Validation.Delete
            End With
     End Select
Next i