行挿入すると見出しが自動作製

Question

添付画像のように、行を挿入されると行の下段の日付が見出しになるようにしたいのです。
VBA初心者なので宜しくお願いします。
画像のようなオレンジ色の塗りつぶしは無し。文字色は濃紺か濃い目の色でお願いします。

ママチャリ · Accepted Answer

初心者ということですが、随分マニアックなことを考えましたね。でも嫌いじゃないので回答させていただきます。
ただ、凝った割にはメリットが少ないような気がします。普通なら「加工日のブレーク毎に見出しを挿入する」ようなマクロを組みそうなものですが…。

では、本題です。
次のVBAを指定した通りのモジュールに張り付けて下さい。
その後、行見出し（シート左側の数字の部分）を右クリックするとメニューが出てくると思いますが、その中に「見出し挿入」が表示されます。それをクリックしてください。

【該当シートのシートモジュール】
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    CommandBars("Row").Reset
    With CommandBars("Row").Controls.Add(Before:=1, Temporary:=True)
        .Caption = "見出し挿入"
        .OnAction = "Insert見出し"
    End With
End Sub

【標準モジュール】
Sub Insert見出し()
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
    With Selection
        .RowHeight = .RowHeight * 2
        Range(Cells(.Row, "A"), Cells(.Row, "B")).Offset(1).Copy _
            Destination:=Cells(.Row, "A")
    End With
End Sub

WindFaller · Answer

やってみたところ、どうやら数式がないと正確な状態は把握できないことが分かりました。かといって、まともに数式を書き換えるということも、そんなに簡単ではないことが分かりました。一旦、数式は全部定数化（数式をなくして値に直）したほうが、問題は少なくて済みそうです。できる相談とそうでないものがありますから、これについてはお勧めというだけです。

'//
Private Sub ChangeTitle()
　On Error Resume Next
　Dim mData As Variant
　With ActiveCell
　If .CurrentRegion.Columns.Count < 3 Then Exit Sub　　'3列以下は作動しない
　　.EntireRow.Copy
　　mData = .Offset(, 1).Value　　'ひとつだけ定数化しただけ
　End With
With ActiveCell
　Application.ScreenUpdating = False
　.EntireRow.Insert
　Range(.Cells(1, 3), Cells(.Row, Columns.Count).End(xlToLeft)).Offset(-1).ClearContents
　.Offset(-1, 1).Value = mData
　.Offset(-1, 1).EntireRow.Interior.ColorIndex = xlColorIndexNone
　.Offset(-1, 1).Font.ColorIndex = 5
　.Offset(-1, 1).EntireRow.RowHeight = ActiveCell.Offset(1).RowHeight * 2
　Application.CutCopyMode = False
　Application.ScreenUpdating = True
End With
　On Error GoTo 0
End Sub

WindFaller · Answer

>下段の日付ではなく上段の日付を表示するようになりました。
>どこがその命令になるのでしょう？

私は、大事なことを読み落としていたことが一つあります。

>IF(F12="","",INDIRECT(F12))のように変更してみました
>見出し挿入すると=INDIRECT(F12)に変わってしまいます
ということで、数式が入っていたわけですよね。

今のコードではダメです。やり方も思いつきましたが、そんなコードは一度も書いたことがありません。ふつう、マクロを使って挿入などをする表は、それを前提に作るものなので、このようなトラブルは発生しません。数式は置かないというのが通例なのです。そうしないと、半端なくややこしくなるものです。

本当は、数式は、定数化させてしまうのが、一番楽です。
もし、それで良ければ、すぐにお教えします。

そうでない場合は、少しお時間いただけますか？その間に、どなたかが気づかれて書かれても、仕方がありません。

あまり大きな表でなければよいのですが、そうでないと、かなり時間も掛かってしまいす。

ママチャリ · Answer

挿入した行の数式をクリアするなら、こんな感じです。
ただ、テーブルに見出し行を追加してしまったら、テーブルが台無しですね。

Sub Insert見出し()
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
    With Selection
        .EntireRow.ClearContents  '←この行を追加！！
        .RowHeight = .RowHeight * 2
        Range(Cells(.Row, "A"), Cells(.Row, "B")).Offset(1).Copy _
            Destination:=Cells(.Row, "A")
    End With
End Sub

WindFaller · Answer

とにかく、ここまで来たなら、後は、微調整だけですね。

でも、#4のようなスタイルで良かったのでしょうか？
実は、まだ、行の挿入イベントにはこだわりが残っています。それは、長年の夢（^^;かもしれません。
少しだけ、右クリックメニューの仕組みが分かってきたのです。

>ROW関数でつけた番号は紺色に変わりましたが、それ以外は何も変わらずタイトルも表示されませんでした。
1列間違えたかな？今、画像をみて、外枠の番号と読み違えたことに気が付きました。失礼しました。

Private Sub ChangeTitle()　のコードの部分から、ここの部分の加工をすればよいです。
ということは、全部1列ずれているということですね。以下、分かりやすい所、With ActiveCell ～　End With までで、中身の挿げ替えをしてみてください。.Offset(-1).　→　.Offset(-1, 1).　で、右にずらしました。

こんなようになります。

With ActiveCell
　Application.ScreenUpdating = False
　.EntireRow.Insert
　Range(.Cells(1, 3), Cells(.Row, Columns.Count).End(xlToLeft)).Offset(-1).ClearContents
　.Offset(-1, 1).EntireRow.Interior.ColorIndex = xlColorIndexNone
　.Offset(-1, 1).Font.ColorIndex = 5
　.Offset(-1, 1).EntireRow.RowHeight = ActiveCell.Offset(1).RowHeight * 2
　Application.CutCopyMode = False
　Application.ScreenUpdating = True
End With
　
後、その状況に応じて、書き換えたり、加える所は、.Offset の部分ですればよいです。

WindFaller · Answer

こんばんは。

リボンカスタマイザーで、ある程度の格好にはなったものの、思った以上に出来がよくないので、組み込み方式は断念しました。

単に、右クリックメニューにいれるだけのマクロにしましたので、良かったら試してください。
メニュー名は『タイトル化』です。
使い方は、左端の行数字のある所をクリックすると、全体の行が選択されます。右クリックすると一番上に、
『タイトル化』
があり、それを実行すると、フォントは、青い色になり、セルの色を塗った書式は消えます。そしてタイトル化します。メニューはブックを閉じると消えるはずです。

'標準モジュール

Sub Auto_Open()
　 On Error Resume Next
　 With Application.CommandBars("ROW")
　　　　 .Controls("タイトル化").Delete
　 End With
　 On Error GoTo 0
　 With Application.CommandBars("ROW")
　　　　With .Controls.Add _
　　　　 (Type:=msoControlButton, Before:=1, Temporary:=True)
　　　 .BeginGroup = False
　　　 .Caption = "タイトル化"
　　　 .OnAction = "ChangeTitle"
　　　End With
　 End With
End Sub
Private Sub ChangeTitle()
　On Error Resume Next
　With ActiveCell
　If .CurrentRegion.Columns.Count < 3 Then Exit Sub　　'3列以下は作動しない
　　.EntireRow.Copy
　End With
With ActiveCell
　Application.ScreenUpdating = False
　.EntireRow.Insert
　Range(.Cells(1, 2), Cells(.Row, Columns.Count).End(xlToLeft)).Offset(-1).ClearContents
　.Offset(-1).EntireRow.Interior.ColorIndex = xlColorIndexNone
　.Offset(-1).Font.ColorIndex = 5
　.Offset(-1).EntireRow.RowHeight = ActiveCell.Offset(1).RowHeight * 2
　Application.CutCopyMode = False
　Application.ScreenUpdating = True
End With
　On Error GoTo 0
End Sub
Sub Auto_Close()
　 On Error Resume Next
　 With Application.CommandBars("CELL")
　　　　 .Controls("タイトル化").Delete
　 End With
　 On Error GoTo 0
End Sub

WindFaller · Answer

#2の回答者です。

ちょっとだけ、この内容についてコメントさせてください。

>理解（…出来るか…ですが（苦笑））できるまで

理解と言っても、数日で理解できるなら、私などが及ぶところではありません。理解というのは、かなり後になってくるわけで、1年後か、2年後、いやもっと先の話になるかもしれません。私自身は、クラスを扱うようになったのは、ずいぶん経ってからです。それにVBA自体は中途半端な言語だから、他の言語を学びながらでないと、わかりにくいはずです。それにもまして、この先、私自身が、何年もExcel VBAを続けられるかどうかでも変わってくると思います。

「難易度、10段階の6」 と書きましたが、このテーマは10年以上も取り組んでいる問題の一つです。そして、#2で書いた方法は、近年は、動かなくなっているという報告もあるそうです。開発環境は、Win10+Office 2013 Professional で、特にイベントは問題はないのですが、現在、「Context Menu Row」 というメニューに反応していますが、「Context Menu Cell」 というメニューには対応していません。

悔しいかな、ずっと取り組んではいますが、今の私には、今回も新しい方法は間に合いそうにはありません。少しだけ進歩した程度です。近い所までは来ている気がするのですが、できません。何が悪いの？と言われたら、それはマイクロソフトが、Officeユーザーには公開しないからです。もうひとつは、やはり英語がネックになっています。今回のために、VS 2015をインストールしました。それで、この開発のためには、C#を勉強しなければならないのかなって思っています。まだ、先は長そうです。しばらく開けていただければ、約束はできそうにもありませんが、次の新しいコードができるかもしれません。

WindFaller · Answer

結局のところ、作成依頼のようですが、私の頭にあるコードは、難易度、10段階の6 ぐらいという気がします。

二つの方法を考えましたが、両方とも、新しいイベントを作るということです。

>行を挿入されると行の下段の日付が見出しになるようにしたいのです。

Excel 2010 以上だとしますと、本来は、コンテクストメニューなどの操作に対して、カスタマイズすることになると思います。そうするとOffice Ribbon Editor　などが必要になります。そういうのは、今現在のVBAなのですね。なんとか、新しい技術についていかなくてはとは思いつつ、簡単だから古いスタイルにしがみついてしまうわけです。XMLでコードを書くことになります。
http://www.ka-net.org/ribbon/ri35.html

とりあえず、そうでないClass 設定を披露します。

>画像のようなオレンジ色の塗りつぶしは無し。文字色は濃紺か濃い目の色でお願いします。
なお、これは良く分かりません。そういうオプションは、とりあえず、ご質問者さん側で考えていただきたいです。リボンの中のメニューにも加えることが可能です。

マウス右クリック-挿入に対して、イベントが働きます。
なお、当たり前ですが、これは、テーブル・オブジェクト上ではうまく行きません。

'標準モジュール
Sub Auto_Open()
'ブックがオープンした時に、設定される
　　Call ClassSetting
End Sub

Private Sub ClassSetting()
　On Error GoTo ErrHandler
Static myClass(1) As Class1
　Dim idx As Variant
　Dim i As Long
　Dim cmdBtn As CommandBarButton
　ThisWorkbook.Activate
　For Each idx In Array(3181, 3183)　　'ボタンのIDが二つある
　　Set cmdBtn = Application.CommandBars("Row").FindControl(, idx)
　　If Not cmdBtn Is Nothing Then
　　　Set myClass(i) = New Class1
　　　cmdBtn.Enabled = True
　　　Set myClass(i).cmdBtn = cmdBtn
　　　i = i + 1
　　End If
　Next
ErrHandler:
　If Err() <> 0 Then
　　MsgBox "設定に失敗しました。", vbExclamation
　End If
End Sub

'------Class モジュール(Class1)------------

Public WithEvents cmdBtn As CommandBarButton　　'新しいイベント

Private Sub cmdBtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
　On Error Resume Next
　With ActiveCell
　If .CurrentRegion.Columns.Count < 3 Then Exit Sub　　'3列以下は作動しない
　　CancelDefault = True
　　.EntireRow.Copy
　End With
　With ActiveCell
　　Application.ScreenUpdating = False
　　.EntireRow.Insert
　　.Offset(-1).EntireRow.RowHeight = ActiveCell.Offset(1).RowHeight * 2
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = True
　End With
　On Error GoTo 0
End Sub

行挿入すると見出しが自動作製

初心者ということですが、随分マニアックなことを考えましたね。

やってみたところ、どうやら数式がないと正確な状態は把握できないことが分かりました。

>下段の日付ではなく上段の日付を表示するようになりました。

挿入した行の数式をクリアするなら、こんな感じです。

とにかく、ここまで来たなら、後は、微調整だけですね。

こんばんは。

#2の回答者です。

結局のところ、作成依頼のようですが、私の頭にあるコードは、難易度、10段階の6 ぐらいという気がします。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング