[[20021212152339]]　『結合セルから結合セルへの値だけのコピーについて』（おじん）　ページの最後に飛ぶ

『結合セルから結合セルへの値だけのコピーについて』（おじん）

　たびたびすみませんが教えて下さい。

A1:B1を結合したセルに、数式にしたがった値が入っています、それをC1：D1の結合されたセルに値だけをコピーしようとすると「この操作には、同じサイズのセルが必要です。」のメッセージが表示されます。困っています、教えて下さい宜しくお願いします。

　コピーされるセルの結合を解除して貼りつければ出来るのですが、数千行に再度セルの結合が必要になりますので大変、困っています。かんたんに出来る方法があれば教えて下さい。

 私は一旦結合されていないセルに「貼付」して、それを「切取＆貼付」で結合されたセルに値を複写しています。

 少し手間ですが、これ以外の方法は知らないもので・・・（すーさん）

 私が使っている方法はすーさんと似ているのですが、

　１）まず、C1とD1の結合を解除して元となるA1とB1の列から値のみを

　　　C1の列にコピーします。

　２）その後、A1:B1の結合されたセルを一つ選択しコピーをした後で、

　　　C1:D1の列でC1に値が入っている範囲を選択し右クリックで

　　　【形式を選択して貼り付け】で【貼り付け】の【書式】を選択し

　　　値がある全ての行を一気に結合します。

　（きん）

 カットやコピーの際、罫線がくっ付いてくるExcelのおせっかい機能は全くどうしようも

 ないものです。一方で、本題の、結合セル同士の値複写などという基本的機能を単純な

 操作で実現できないのは一体どういうわけなのでしょうか。しかも、形式を選択して値を

 貼り付けようとすると、「この操作には同じサイズの結合セルが必要です」などと訳の

 わからないメッセージが出てきます。

 そこで、VBA初心者ですが、以下のようなマクロを試作しました。

 例えば「範囲の記憶()」をCtrl+r、「値のみ複写()」をCtrl+vに割り付けて使用すると、

 作業がキーボード操作でスイスイできます。なお、ワークエリアとして1000行目あたりを

 使用しているところがいまいちですが・・・（必要なら、決して使わない3000行目あたり

 に変更することは何ら差し支えないのですが）。

 ちなみに、本マクロでは、「書式複写」機能を使っていますので、罫線も一緒にくっ付い

 てきます。

 以下、長々と紙面を汚します。

 Dim 左列 As Integer

 Dim 右列 As Integer

 Dim 上行 As Integer

 Dim 下行 As Integer

 Dim 列w As Integer

 Dim 行w As Integer

 Dim ad元 As Variant

 Dim ad先 As Variant

 Dim I As Integer, J As Integer

 Sub 範囲の記憶()

  With Selection

    上行 = .Row

    下行 = .Rows(Selection.Rows.Count).Row

    左列 = .Columns(1).Column

    右列 = .Columns(Selection.Columns.Count).Column

  End With

 ad元 = Selection.Address

 'コピー状態を模擬

 Selection.Copy

 End Sub

 Sub 値のみ複写()

 Application.ScreenUpdating = False '画面更新しない

 ad先 = Selection.Address

 '第１ワークエリアに複写先の範囲全体を罫線ともどもコピーする

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 Selection.Copy

 Range("AA1000").PasteSpecial xlPasteAll

 '結合セルの決して存在しないであろう第２ワークエリアに順次、値コピー

 J = 0

 I = 0

 値複写:

 '+100,-100などは、複写元の左上隅のセルが結合セルである場合に対処するための"おまじな い"。

 Range(Cells(上行 + 100, 左列 + 100), Cells(上行 + 100, 左列 + 100)).Offset(-100 + I, -100 + J).Select

 With Selection

 行w = .Rows(Selection.Rows.Count).Row

 列w = .Columns(Selection.Columns.Count).Column

 End With

 If 列w > 右列 Then

 GoTo 書式複写

 Else

 End If

 If 行w > 下行 Then

 GoTo 次列

 Else

    Application.CutCopyMode = False

    Selection.Copy

    '結合セルが決して存在しないであろう遠い個所をワークエリアとして使用する

    Range("CA1000").Offset(I, J).Select

    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _

        False, Transpose:=False

 End If

 I = I + 1

 GoTo 値複写:

 次列:

 J = J + 1

 I = 0

 GoTo 値複写:

 '第２ワークエリアのセル構造を、複写元範囲と同じセル構造に強制変更する

 書式複写:

 Range(ad元).Select

 Selection.Copy

 Range("CA1000").Select

 Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

        False, Transpose:=False

 '第２ワークエリアを複写先にコピーする

 Selection.Copy

 Range(ad先).Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

    '複写先範囲のセル構造が不当な場合、Excel本来の機能によりエラーとなる

 ActiveSheet.Paste

 GoTo ゴミ消去

 '第１ワークエリアから、書式を複写先にコピーする

 '複写先の罫線を保持させるが、同時にセル構造も保持され、複写元のセル構造と完全一致でない場合には、それなりにしか複写されない

 Range("AA1000").Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 Selection.Copy

 Range(ad先).Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 On Error GoTo ERRRTN

 Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

        False, Transpose:=False

 'ワークエリアのゴミを消去

 ゴミ消去:

 '1回だけではゴミが残ることがあるので・・

 For CNT = 1 To 5

 Range("CA1000").Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 Application.CutCopyMode = False

    Selection.EntireRow.Delete

 Next

 '複写先範囲を選択状態でマクロ終了

 Range(ad先).Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 GoTo endrtn

 'エラー処理

 ERRRTN:

    'エラーメッセージ

 MsgBox "コピー領域と貼り付け領域の形が違うため、情報を貼り付けることができません。"

    'ワークエリアのゴミを消去

 For CNT = 1 To 5

    '1回だけではゴミが残ることがあるので・・

 Range("CA1000").Select

 Selection. _

 Range(ad元).Offset(-上行 + 1, -左列 + 1).Select

 Application.CutCopyMode = False

    Selection.EntireRow.Delete

 Next

    '複写先左上隅セルを選択状態でマクロ終了

 Range(ad先).Select

 GoTo endrtn

 endrtn:

 Application.ScreenUpdating = True '画面更新する

 End Sub

 （エータロー）

コメント返信：