Excel VBA复制粘贴无法复制单元格边框问题求助

问题描述 #

我在Excel VBA中尝试将带有完整边框的单元格复制粘贴到相邻单元格时遇到问题。原始表格如图1所示，我需要删除第18行的P1，将U2连同其边框格式一并移至G列，但操作后G列出现了蓝色下边框（如图2），和预期结果（如图3）不符。相关VBA代码如下：

For col_num = col_num To 12
                                        
    'MsgBox stored_row & col_num
                                        
                                       
         If col_num = 12 Then
            Exit For
         End If
        
            If Sheets("DSS").Cells(stored_row, col_num + 1).Value <> "" Then
                
                Sheets("DSS").Cells(stored_row, col_num + 1).Copy
                Sheets("DSS").Cells(stored_row, col_num).PasteSpecial
                Application.CutCopyMode = False

                Sheets("DSS").Cells(stored_row, col_num + 1).Value = ""
            
            ElseIf Sheets("DSS").Cells(stored_row, col_num + 1).Value = "" Then
                
                Sheets("DSS").Cells(stored_row, col_num + 1).Copy
                Sheets("DSS").Cells(stored_row, col_num).PasteSpecial
                Application.CutCopyMode = False

                'Exit For
            End If
            
            If Sheets("DSS").Cells(stored_row - 1, col_num).Value <> "" Then
                    Cells(stored_row, col_num).Select
                        With Selection.Borders(xlEdgeTop)
                            .LineStyle = xlContinuous
                            .Color = vbBlue
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
            End If
             If Sheets("DSS").Cells(stored_row + 1, col_num).Value <> "" Then
                    Cells(stored_row, col_num).Select
                        With Selection.Borders(xlEdgeBottom)
                            .LineStyle = xlContinuous
                            .Color = vbBlue
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
            End If
            
Next

问题分析 #

代码存在两个核心问题：

1. 复制粘贴后添加了手动强制设置上下边框的逻辑，当Sheets("DSS").Cells(stored_row + 1, col_num).Value <> ""条件成立时，会给目标单元格添加蓝色粗下边框，直接覆盖了复制过来的原有边框格式，这就是出现非预期蓝色下边框的原因。
2. 部分单元格引用未指定工作表（如Cells(stored_row, col_num).Select），可能导致操作到当前激活的错误工作表；同时PasteSpecial未明确参数，虽默认粘贴全部，但后续的边框修改会破坏原有格式。

解决方案 #

1. 删除手动设置上下边框的代码段，保留复制过来的原始边框格式。
2. 明确PasteSpecial参数为xlPasteAll，确保单元格值、格式（包括边框）完整复制。
3. 统一所有单元格操作的工作表对象，避免跨表错误。
4. 调整循环范围，简化逻辑，避免不必要的判断。

修改后的代码如下：

' 请根据实际需求设置col_num的起始值，比如G列对应列号7
For col_num = 7 To 11 ' 原逻辑col_num=12时退出，因此循环到11即可
    Dim sourceCell As Range, targetCell As Range
    Set sourceCell = Sheets("DSS").Cells(stored_row, col_num + 1)
    Set targetCell = Sheets("DSS").Cells(stored_row, col_num)
    
    ' 复制源单元格的所有内容与格式（含边框）
    sourceCell.Copy
    targetCell.PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    
    ' 清空源单元格内容
    sourceCell.Value = ""
    
    ' 若源单元格原本为空，直接退出循环（匹配原逻辑）
    If sourceCell.Value = "" Then
        Exit For
    End If
Next

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