Excel VBAで同じ日付のセル結合を行う方法とは？

2020/04/30 08:29

このQ&Aのポイント

Excel VBAを使用して、特定の条件でセルを結合するマクロを作成する方法について教えてください。
処理1では、特定の範囲のセルをコピーして別の場所にペーストする処理を行います。
処理2では、同じ日付のセルの値を結合する方法について説明します。

NuboChan
お礼率65% (1342/2037)

Excel（エクセル）
回答数4
ありがとう数2

みんなの回答 （4）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

kkkkkm
ベストアンサー率66% (1769/2651)

2020/04/30 12:13 回答No.4

> 「倍々の例」（sub test2()) のコードありがとうございます。 No2の回答は勘違いから出た間違い回答なので申し訳ないですが無視してください。結合しているセルとしていないセルを組み合わせてコピペしたときにうまくいかない事例もあり、それが頭に浮かんで駄目なんだと思い込んだ間違い回答です。なので結合を解除する必要はありません。 No3を試してみてください。 No1の補足にあるコードでしたら Cells(ActiveCell.Row + 1, "A").Resize(1, 5).Insert Shift:=xlDown でエラーになっていると思います(たとえばA1,A2結合されているセルが選択されている場合、A2に貼り付け挿入しようとしている) ご利用になりたい部分ですが If Cells(ActiveCell.Row, 1).MergeCells Then Cells(ActiveCell.Row,1).UnMerge End If したときに先頭行以外のデータはなしですので If .Value = .Offset(1, 0).Value Then この条件に合わなくなります。 Set myRng = Union(myRng, .Offset(1, 0)) が有効になりませんから、もとの複数行を結合してくれないと思います。

質問者

お礼 2020/04/30 13:13

何度もありがとうございます。私の考えは、甘かったようなので　提示いただいた「Test3（）」を素直に利用させて頂くことにしました。コードをコピペして、希望の処理が出来るのを確認しました。改めて、お礼申し上げます。

ログインすると、全ての回答が全文表示されます。

その他の回答 (3)

kkkkkm
ベストアンサー率66% (1769/2651)

2020/04/30 10:21 回答No.3

失礼2回に分けなくても1回でいけました。挿入位置を勘違いしてたので最初できなかった。 Sub Test3() Dim MRCount As Long Application.DisplayAlerts = False With Cells(ActiveCell.Row, "A").MergeArea MRCount = .Rows.Count End With Cells(ActiveCell.Row, "A").Resize(1, 5).Copy Cells(ActiveCell.Row + MRCount, "A").Resize(1, 5).Insert Shift:=xlDown Cells(ActiveCell.Row, "A").Resize(MRCount + 1, 1).Merge Application.CutCopyMode = False Application.DisplayAlerts = True End Sub

ログインすると、全ての回答が全文表示されます。

kkkkkm
ベストアンサー率66% (1769/2651)

2020/04/30 10:12 回答No.2

> ターゲットセルが既に結合されている場合は、エラーとなりました。結合されているA1から結合されていないE1までを選択してコピペ挿入することはできません。なので、回答では結合されている部分とされていない部分を分けてコピペ挿入しています。 A1とA2が結合されているとしてA1からE2までの範囲をコピペ挿入することはできますが、行数が倍々に増えていきます。倍々の例です。 Sub Test2() Dim MRCount As Long Application.DisplayAlerts = False Application.DisplayAlerts = False With Cells(ActiveCell.Row, "A").MergeArea MRCount = .Rows.Count End With Cells(ActiveCell.Row, "A").Resize(MRCount, 5).Copy Cells(ActiveCell.Row + MRCount, "A").Resize(MRCount, 5).Insert Shift:=xlDown Cells(ActiveCell.Row, "A").Resize(MRCount + 1, 1).Merge Application.CutCopyMode = False Application.DisplayAlerts = False End Sub

質問者

お礼 2020/04/30 10:41

「倍々の例」（sub test2()) のコードありがとうございます。処理が複雑になり理解できない状態に成りそうです。私が提示したコードで結合しているのは、A列なのでターゲットセルが結合セルか？　　例　＞　If Cells(i, 1).MergeCells Then　---- 判断して結合していたら、　　　例　＞　Range("A1").UnMerge のように結合解除するではだめなのでしょうか　？それでも処理できそうなら、　私の提示したコードで上記判断を加味したコードをお願いします。　　　　

ログインすると、全ての回答が全文表示されます。

kkkkkm
ベストアンサー率66% (1769/2651)

2020/04/30 09:28 回答No.1

結合したセルを再度追加結合する可能性を考えてA列とBからE列を分けて別に挿入ペーストしてます。 Sub Test() Dim MRCount As Long Application.DisplayAlerts = False With Cells(ActiveCell.Row, "A").MergeArea MRCount = .Rows.Count End With Cells(ActiveCell.Row, "A").Copy Cells(ActiveCell.Row + MRCount, "A").Insert Shift:=xlDown Cells(ActiveCell.Row, "B").Resize(1, 4).Copy Cells(ActiveCell.Row + 1, "B").Resize(1, 4).Insert Shift:=xlDown Cells(ActiveCell.Row, "A").Resize(MRCount + 1, 1).Merge Application.CutCopyMode = False Application.DisplayAlerts = True End Sub

質問者

補足 2020/04/30 09:44

ありがとうございます。ネットを参考に以下で処理できそうでしたが、ターゲットセルが既に結合されている場合は、エラーとなりました。どこを修正すべきですか　？ Sub 行挿入() Dim myRng As Range, myRow As Long Cells(ActiveCell.Row, "A").Resize(1, 5).Copy Cells(ActiveCell.Row + 1, "A").Resize(1, 5).Insert Shift:=xlDown Application.CutCopyMode = False Set myRng = Range("A1") For myRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row With Cells(myRow, 1) If .Value = .Offset(1, 0).Value Then Set myRng = Union(myRng, .Offset(1, 0)) Else Application.DisplayAlerts = False myRng.Merge Application.DisplayAlerts = True Set myRng = .Offset(1, 0) End If End With Next MsgBox "日付を挿入しました", vbOKOnly, "挿入完了" End Sub

ログインすると、全ての回答が全文表示されます。