Excel VBA开发需求：复制指定列并移除条件格式与数据验证

问题说明 #

• 核心需求：遍历「Model Storage List」工作表，将D列值为Sendable或Sent To Client的行的A-F列复制到「Client Ship List」，之后删除源表对应行。
• 当前代码痛点：
  • 复制整行（包含不需要的G-J列）
  • 连带复制源表的条件格式（Conditional Formatting）和数据验证（Data Validation）
  • 手动删多余列时误删目标表已有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

尝试的修改片段 #

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

修正后的完整代码 #

Sub MoveToClientShipping()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetRow As Long
    
    ' 统一D列文本格式为首字母大写（解决大小写匹配问题）
    With ThisWorkbook.Worksheets("Model Storage List").Range("D1", Cells(Rows.Count, "D").End(xlUp))
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
   
    ' 定义源表和目标表
    Set sourceSheet = ThisWorkbook.Worksheets("Model Storage List")
    Set targetSheet = ThisWorkbook.Worksheets("Client Ship List")

    ' 获取源表D列最后一行
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    ' 获取目标表A列最后一行（确定插入位置）
    targetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 从下往上遍历，避免删除行导致的索引错位
    For i = lastRow To 1 Step -1
        ' 合并判断条件，简化代码
        Select Case sourceSheet.Cells(i, "D").Value
            Case "Sendable", "Sent To Client"
                targetRow = targetRow + 1
                ' 仅复制A-F列，粘贴值和格式（不复制条件格式/数据验证）
                sourceSheet.Range("A" & i & ":F" & i).Copy
                targetSheet.Cells(targetRow, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                targetSheet.Cells(targetRow, "A").PasteSpecial Paste:=xlPasteFormats
                ' 删除源表对应行
                sourceSheet.Rows(i).Delete
        End Select
    Next i
    
    ' 清除剪贴板，避免后续操作受影响
    Application.CutCopyMode = False
    MsgBox "Client Ship List Populated | Please fill in missing criteria."
End Sub

关键修改说明 #

1. 精准复制列：用sourceSheet.Range("A" & i & ":F" & i)替代整行复制，只取需要的A-F列，从根源避免多余列被复制。
2. 避免复制条件格式/数据验证：使用PasteSpecial分别粘贴值+数字格式、单元格格式，既保留视觉样式，又不会带入源表的条件规则和数据验证。
3. 修复目标行计算：改用目标表A列最后一行确定插入位置，避免原代码中NextFree和targetRow混用导致的错误。
4. 合并判断逻辑：用Select Case合并两个条件判断，代码更简洁。
5. 修复原代码语法错误：原代码中第二个If语句未添加End If，已修正。
6. 清除剪贴板：添加Application.CutCopyMode = False，避免复制状态残留影响操作。

内容的提问来源于stack exchange，提问作者MKitten