0

既存のテーブルに隣接する列で機能するマクロを作成しようとしています。このマクロの目的は、テーブルに存在するセル結合を取得し、それらを次の 2 つの列にコピーすることです (これは、より大きな目的を持つもののヘルパー メソッドです)。私のコードは以下のとおりですが、次の行で発生する「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

サブに渡される範囲は、複製したいすべてのマージされた領域 (または少なくともそれらの左上隅) を完全に囲む単一領域の長方形の範囲でなければなりません。colOffsetマージをコピーする列の数です。

于 2013-07-09T18:39:58.397 に答える