0

我正在尝试创建一个适用于与现有表相邻的列的宏。此宏的目的是获取表格中存在的任何单元格合并并将它们复制到接下来的两列中（这是用于更大目的的辅助方法）。我的代码在下面，但我收到一条错误消息，上面写着“Range 类的PasteSpecial 方法失败”，该错误发生在以下行：

        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

正上方的行是一个测试行，用于检查代码是否在循环的第一次迭代中工作，确实如此。但是，一旦代码尝试重新迭代并再次粘贴，代码就会失败。我相信这是因为“Selection.PasteSpecial”调用不再引用正确的对象，但我不确定如何修复它。

Sub extendColumnMerges()
'
' Works on a column adjacent to a table by extending the column's merge-formatting to the selected column
' Active cell must begin as the first cell in the column immediatley adjacent the table on the right
'
    Dim cols As Integer
    cols = 2

    'Selects the last column of the table and copies the selection into the new column, modifying the format of the new column
    Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, -1).End(xlDown)).Select
    Selection.Copy
    'Pastes the columns' merge-formatting into each specified column adjacent the table on the right
    For c = 1 To cols
        ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.Value = "Yes"
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        'Removes the formatting from the cells in the new column
        With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        'Removes borders from the newly modified column
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        ActiveCell.Select
   Next c
End Sub

此外，如果有任何关于如何以更优雅的方式编码的建议，他们将不胜感激。复制格式然后删除边框和填充在代码中似乎很庞大。谢谢。

4

1 回答 1

0

这似乎对我有用：

Sub Tester()
    'copy the merged areas of the current selection 4 columns to the right
    ReplicateMergeAreas Selection, 4
End Sub


Sub ReplicateMergeAreas(sourceArea As Range, colOffset As Long)

Dim rw As Long, col As Long
Dim c As Range, c2 As Range
Dim rngTL As Range

'set the cell at the top-left of the "destination" range
'  (actually offset -1,-1 to make it easier to set range 'c2')
Set rngTL = sourceArea.Cells(1).Offset(-1, colOffset - 1)

'loop through each cell in the "source" range
For rw = 1 To sourceArea.Rows.Count
    For col = 1 To sourceArea.Columns.Count
        'c=cell in source range
        Set c = sourceArea.Cells(rw, col)
        'is this cell merged? 
        If c.MergeArea.Cells.Count > 1 Then
            'c2=corresponding cell in the destination range
            Set c2 = rngTL.Offset(rw, col)
            'Is the "destination" cell already merged?
            '   skip if yes 
            If c2.MergeArea.Cells.Count = 1 Then
                'set merge area the same size as the "source" cell
                c2.Resize(c.MergeArea.Rows.Count, _
                          c.MergeArea.Columns.Count).Merge
            End If
        End If
    Next col
Next rw

End Sub

传递给 sub 的范围必须是一个单区域矩形范围，它完全包围您要复制的所有合并区域（或至少它们的左上角）。colOffset是您要将合并复制到的列数。

于 2013-07-09T18:39:58.397 回答