エクセルのマクロ

Question

こんばんは、宜しくお願いします。
エクセルで行を挿入し前行の数式をコピーするマクロの記録を行ったのが下記の内容です。
Sub Sounyu()
'
' Sounyu Macro
'
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown
    Range("B3:C3").Select
    Selection.AutoFill Destination:=Range("F3:F4"), Type:=xlFillDefault
    Range("F3:F4").Select
    Range("G3").Select
    Selection.AutoFill Destination:=Range("G3:G4"), Type:=xlFillDefault
    Range("G3:G4").Select
    Range("A2").Select
End Sub

最後の　Range("A2").Selectを挿入した行のＡのセルへ
カーソルがいくようにするにはどのように変更したら
良いのでしょうか？
教えてください。

kazuhiko5681 · Accepted Answer

こんばんわ。早速修正マクロを作ってみました。次の手順で操作してみて下さい。１.前回マクロを貼り付けたブックを立ち上げる。２.Sheet1モジュールシートを開き、コードをすべて削除した後、下記のコードをコピー・ペーストする。 Private Sub Worksheet_Activate() Call Module1.myCell_Select End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myRow As Long Dim myCnt As Integer Dim i As Integer Dim myMsb As Integer Dim myCell1 As String Dim myCell2 As String myRow = Target.Row myCnt = Cells(1, Columns.Count).Column For i = 1 To myCnt If Target.Address = Cells(myRow, i).Address Then Exit Sub Next i If Range("A" & myRow).Value = "" Then Exit Sub myMsb = MsgBox("削除処理を実行してもよろしいですか？", vbYesNo + vbQuestion, "作　業　確　認") If myMsb = vbNo Then End Application.EnableEvents = False Target.Delete shift:=xlShiftUp Application.EnableEvents = True If myRow = 2 And Range("A" & myRow).Value = "" Then Exit Sub If Cells(Rows.Count, 7).End(xlUp).Offset(0, -6).Value = "" Then Application.EnableEvents = False Cells(Rows.Count, 7).End(xlUp).Value = "" Cells(Rows.Count, 8).End(xlUp).Value = "" Application.EnableEvents = True End If Application.EnableEvents = False Call Module1.myCalculation(myRow) Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim myRow As Long Dim myColumn As Integer Dim myRange As Range myRow = Target.Row If myRow = 1 Then Exit Sub myColumn = Target.Column Select Case myColumn Case 1, 6, 7 If Target.Address = Range("A" & myRow).Address Then If myRow = 1 Or myRow = 2 Then Exit Sub If Range("A" & myRow).Value <> "" Then If Target.Value = Target.Offset(-1, 0).Value Then If Target.Offset(1, 0).Value <> "" Then Rows(myRow + 1 & ":" & myRow + 1).Insert shift:=xlShiftDown End If Else Rows(myRow & ":" & myRow).Insert shift:=xlShiftDown End If If Cells(Rows.Count, 1).End(xlUp).Row < Cells(Rows.Count, 7).End(xlUp).Row Then Application.EnableEvents = False Cells(Rows.Count, 7).End(xlUp).Value = "" Cells(Rows.Count, 8).End(xlUp).Value = "" Application.EnableEvents = True End If End If Application.EnableEvents = False Call Module1.myCell_Select Application.EnableEvents = True End ElseIf Target.Address = Range("F" & myRow).Address Then If myRow = 1 Then Exit Sub If Range("A" & myRow).Value = "" Then Exit Sub Application.EnableEvents = False If Target.Offset(0, 1).Value = "" Then Range("G" & myRow).Select Application.EnableEvents = True End Else If Target.Value = "" Then Target.Offset(0, 2).Value = Target.Offset(0, 1).Value * 0.75 Else Target.Offset(0, 2).Value = Target.Offset(0, 1).Value End If End If Application.EnableEvents = True ElseIf Target.Address = Range("G" & myRow).Address Then If myRow = 1 Then Exit Sub If Range("A" & myRow).Value = "" Then Exit Sub Application.EnableEvents = False If Target.Offset(0, -1).Value = "" Then Target.Offset(0, 1).Value = Target.Value * 0.75 Else Target.Offset(0, 1).Value = Target.Value End If Application.EnableEvents = True End If Application.EnableEvents = False Call Module1.myCalculation(myRow) Range("A" & myRow + 1).Select Application.EnableEvents = True End Select End Sub また、不都合なことがありましたら、お知らせ下さい。

kazuhiko5681 · Answer

こんばんは。コマンドボタンは、次のように操作して出します。
また、コマンドボタンを配置するだけでimogasiさんのマクロは動きます。

　・ファイルメニューにマウスポインターをあわせて右クリックし、出てき　　たプルダウンメニューのVisual Basicをクリックする。 
　・出てきたツールバーの右から３番目(コントロールツールボックス)をク　　リックし、コントロールツールボックスの一番右側の上から２番のコマ　　ンドボタンをクリックし、シートの適当な位置でクリックする。 
　・ツールバーの２番目(デザインモード)のボタンが押された状態になって　　いたらそのボタンをクリックしてＯＦＦの状態にする。 

この状態にしてボタンをクリックしてみて下さい。動作します。

imogasi · Answer

＃１４のものです。私の回答に#16で言及があったので。
（１）私のはエベントを捉えているので、挿入モードと非挿入　モードを分けないと、他の操作に差し支えるのであのようにしました。
　＃５はそういう方向ではない。
（２）Changeエベントを使っている。
　＃５はそういう方向ではない。
（３）基本的に挿入の部分のコードは誰が書いても似たも　のになると思いますが。
（４）＞「G2に入れた数式をG3へコピーすると数式の選択セル　も変更されてしまう」
　これは本質問が、コピー後コピー元とコピー先が全く変更し　ないと言う条件付きであるとは、解せませんでした。
　また問題にされる意味が判りません。
（５）私が＃１４を載せようと思ったのは、回答文が長く（私　のも（１）のために長くなっており済みません）質問者の理　解や読持続力を超えているのではと思ったためでした。
　しかし私もどんどん増やしているので、済みません。

kazuhiko5681 · Answer

こんばんわ。皆様に喜んでいただけて私も作った甲斐があります。何度も修正にお手数をおかけして時間がかかり、申し訳ございませんでした。
おせっかいかもしれませんが、＃１４imogasiさんの作られたマクロは、私が＃５でご紹介したサンプルマクロと同じ内容のものです。
imogasiさんのマクロを実行すると、G2に入れた数式をG3へコピーすると数式の選択セルも変更されてしまうという問題が生じると思います。
老婆心ながら、生意気なことを書かせていただきました。ご無礼をお許し下さい。

imogasi · Answer

＃４のものです。補足要求に対し、補足します。
（１）ボタンは、ＶＢのツールバーのコマンドボタンをワークシートにドロップアンドドロップして、貼り付けます。
ＶＢのＦｏｒｍ１のようにＦｏｒｍを持ってくる必要はありません。邪魔です。シートがコントロールの台帳的役割をします。ＶＢはＦｏｒｍが必須ですが、エクセルはワークシートに
貼り付けられます。データの邪魔にならないところに貼り付けてください。
（２）ボタンのＣａｐｔｉｏｎは、初期状態として、プロパティ画面等で「挿入」とすべきですが、１回クリックすると「挿入」になるので省略しました。
（３）（Ａ）ボタンはＳｈｅｅｔ１上の貼り付けられたコントロール（Ｂ）Selection_ChangeはＳｈｅｅｔ１のイベントなので、プロジェクトのＳｈｅｅｔ１をダブルクリックして出てくる画面に、両方とも貼り付けて下さい。
（４）マクロの記録をボタンに登録するのは（任意の時に）簡単に起動するために象徴化するのですが、（Ａ）本件のコマンドボタンの押し下げ（Ｂ）Ｓｈｅｅｔ１のＳｅｌｅｃｔの変化を契機とする（プログラムの１部の実行の契機となる）もので
同列には論ぜられません。Ａがないと、Ｂはシートを開くと常時待機体制になります。それを常時行われないように、安全装置として、非挿入モードを作っているわけです。

imogasi · Answer

＜もっと簡単に出来るのではないか＞
#3で補足要求を入れたものです。質問を理解して頂けなくて
残念でした。それは良いのです。しかし他のご解答のたびに
解答が入りますので、読んでいました。しかし膨大な補足と
解答を読解できる力がありませんで失礼しますが,こんなに
長くなるのと思い、
「エクセルで行を挿入し前行の数式をコピーする」事を短く
実現を目指しました。
●＜操作＞
（１）Sheet1にボタンを１つ貼り付ける。「非挿入」と「挿入」はクリックで反転する。必ず「挿入」の表示にして、コピー元のセルをクリックする。
（２）クリックした行の直下行に１行自動的に挿入し、挿入した行に、クリックした行をコピーします。
（３）操作後は挿入行をＳｅｌｅｃｔ状態ですが
　　　任意のセルをＳｅｌｅｃｔ状態にする。
　　　クリックしたセルの直下セルをＳｅｌｅｃｔ状態に
　　　することは簡単ですが省略します。
（４）［非挿入」には自動的にします。
（５）コピー元以外にカーソルを一旦置いて、挿入状態にして、挿入行をクリックして貰ったほうが良い。
●＜コード＞
ボタンについては、ＶＢＥのSheet1のコード面に
Private Sub CommandButton1_Click()
If CommandButton1.Caption = "挿入" Then
CommandButton1.Caption = "非挿入"
Else
CommandButton1.Caption = "挿入"
End If
End Sub
＝＝＝＝＝＝
同じくSheet1のコードの画面に
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If CommandButton1.Caption = "挿入" Then
r = Target.Row: c = Target.Column
Worksheets("sheet1").Cells(r + 1, c).EntireRow.Insert
CommandButton1.Caption = "非挿入"
Rows(r).Copy
Rows(r + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'-----
Else
 Exit Sub
End If
End Sub
を貼り付けてください。
●テストする時は、「元に戻す」が効きませんので、必ずコピー
したシートで行ってください。

kazuhiko5681 · Answer

こんにちは。
修正するのはよろしいのですが、どの様に修正するのか教えて下さい。以上の点がわからないと、修正プログラムを書くことができません。

kazuhiko5681 · Answer

こんばんわ。少し手間を取ってしまいましたが、サンプルマクロを作り上げることができました。初期入力・追加入力・行削除を実行後、自動で再計算できるように作りました。また、価格と実価格それぞれの合計も最終行の２行下へ自動計算で値を出力できるように作りました。ただし、行削除を実行するときは、必ず行番号をクリックし、行全体を選択するようにしてください。１.ＶＢＥ画面左上のSheet1の上で右クリック→挿入→標準モジュールをクリック２.画面右側の白い部分に下のコードをコピー・ペーストする。 Sub myCalculation(myRow As Long) Dim myCell1 As String Dim myCell2 As String Dim mySum1 As Long Dim mySum2 As Long If Range("A" & myRow).Value = "" Then If Range("A" & myRow - 2).Value = "" Or myRow = 3 Then Range("I" & myRow - 1).Value = Range("H" & myRow - 1).Value Else myCell2 = Range("H" & myRow).End(xlUp).Address myCell1 = Range(myCell2).End(xlUp).Address Range("I" & myRow - 1).Value = "" Range(myCell2).Offset(0, 1).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If Else If Range("A" & myRow - 1).Value = "" Or myRow = 2 Then If Range("A" & myRow + 1).Value = "" Then Range("I" & myRow).Value = Range("H" & myRow).Value Else myCell1 = Range("H" & myRow).Address myCell2 = Range(myCell1).End(xlDown).Address Range("I" & myRow - 1).Value = "" Range(myCell2).Offset(0, 1).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If ElseIf Range("A" & myRow - 1).Value <> "" Then If Range("A" & myRow + 1) = "" Then myCell2 = Range("H" & myRow).Address myCell1 = Range(myCell2).End(xlUp).Address Else myCell1 = Range("H" & myRow).End(xlUp).Address myCell2 = Range("H" & myRow).End(xlDown).Address End If Range("I" & myRow - 1).Value = "" Range(myCell2).Offset(0, 1).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If End If myCell1 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6).Address myCell2 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).Address Range(myCell1).Offset(2, 0).Value = Application.WorksheetFunction.Sum(Range("G2:" & myCell1)) Range(myCell2).Offset(2, 0).Value = Application.WorksheetFunction.Sum(Range("H2:" & myCell2)) End Sub Sub myCell_Select() Dim myRow As Long Dim myColumn As Integer myRow = Cells(Rows.Count, 1).End(xlUp).Row myColumn = Cells(1, Columns.Count).Column myColumn = Cells(myRow, myColumn).End(xlToLeft).Column Select Case myColumn Case 1 Cells(myRow, 2).Select Case 2 Cells(myRow, 3).Select Case 3 Cells(myRow, 4).Select Case 4 Cells(myRow, 5).Select Case 5 Cells(myRow, 6).Select Case 6 Cells(myRow, 7).Select Case Else Cells(myRow + 1, 1).Select End Select End Sub ３.Sheet1のモジュールシートに、下のコードをコピー・ペストする。 Private Sub Worksheet_Activate() Call Module1.myCell_Select End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myRow As Long Dim myCnt As Integer Dim i As Integer Dim myMsb As Integer Dim myCell1 As String Dim myCell2 As String myRow = Target.Row myCnt = Cells(1, Columns.Count).Column For i = 1 To myCnt If Target.Address = Cells(myRow, i).Address Then Exit Sub Next i If Range("A" & myRow).Value = "" Then Exit Sub myMsb = MsgBox("削除処理を実行してもよろしいですか？", vbYesNo + vbQuestion, "作　業　確　認") If myMsb = vbNo Then End Application.EnableEvents = False Target.Delete shift:=xlShiftUp Application.EnableEvents = True If myRow = 2 And Range("A" & myRow).Value = "" Then Exit Sub If Cells(Rows.Count, 7).End(xlUp).Offset(0, -6).Value = "" Then Application.EnableEvents = False Cells(Rows.Count, 7).End(xlUp).Value = "" Cells(Rows.Count, 8).End(xlUp).Value = "" Application.EnableEvents = True End If Application.EnableEvents = False Call Module1.myCalculation(myRow) Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim myRow As Long Dim myColumn As Integer Dim myRange As Range myRow = Target.Row If myRow = 1 Then Exit Sub myColumn = Target.Column Select Case myColumn Case 1, 6, 7 If Target.Address = Range("A" & myRow).Address Then If myRow = 1 Or myRow = 2 Then Exit Sub If Range("A" & myRow).Value <> "" Then If Target.Value = Target.Offset(-1, 0).Value Then If Target.Offset(1, 0).Value <> "" Then Rows(myRow + 1 & ":" & myRow + 1).Insert shift:=xlShiftDown End If Else Rows(myRow & ":" & myRow).Insert shift:=xlShiftDown End If If Cells(Rows.Count, 1).End(xlUp).Row < Cells(Rows.Count, 7).End(xlUp).Row Then Application.EnableEvents = False Cells(Rows.Count, 7).End(xlUp).Value = "" Cells(Rows.Count, 8).End(xlUp).Value = "" Application.EnableEvents = True End If End If Application.EnableEvents = False Call Module1.myCell_Select Application.EnableEvents = True End ElseIf Target.Address = Range("F" & myRow).Address Then If myRow = 1 Then Exit Sub If Range("A" & myRow).Value = "" Then Exit Sub Application.EnableEvents = False If Target.Offset(0, 1).Value <> "" Then If Target.Value = "" Then Target.Offset(0, 2).Value = Target.Offset(0, 1).Value * 0.75 Else Target.Offset(0, 2).Value = Target.Offset(0, 1).Value End If End If Application.EnableEvents = True ElseIf Target.Address = Range("G" & myRow).Address Then If myRow = 1 Then Exit Sub If Range("A" & myRow).Value = "" Then Exit Sub Application.EnableEvents = False If Target.Offset(0, -1).Value = "" Then Target.Offset(0, 1).Value = Target.Value * 0.75 Else Target.Offset(0, 1).Value = Target.Value End If Application.EnableEvents = True End If Application.EnableEvents = False Call Module1.myCalculation(myRow) Call Module1.myCell_Select Application.EnableEvents = True End Select End Sub ４.ThisWorkbookのモジュールシートに下のコードをコピーペーストする。 Private Sub Workbook_Open() Call Module1.myCell_Select End Sub もし、不都合なことがありましたらお知らせ下さい。

kazuhiko5681 · Answer

こんばんわ。あなた様が作られている表構成を確認するために、サンプルマクロを作りました。前回と同じように新規ブックを開き、Sheet1のモジュールシートに下記のコードを貼り付け、データー入力してみて下さい。一度入力して自動計算をした値は「区分」の有無を変更した時に自動計算できるように訂正してあります。もし、この表構成でよろしければ次のことをお知らせ下さい。完全なサンプルマクロを作りたいと思います。１.今回は空白行を設けましたが、この行にデータを入力することがあるかどうか。もし、あるとしたらどのようなデータを入力するのか。２.１行すべてを削除することがあるのかどうか。また、その時合計の自動計算が必要かどうか。３.その他気がついた点で、修正してほしい内容 Private Sub Worksheet_Change(ByVal Target As Range) Dim myRow As Long Dim myCell1 As String Dim myCell2 As String Dim myRange As Range myRow = Target.Row If Target.Address = Range("A" & myRow).Address Then If myRow = 1 Or myRow = 2 Then Exit Sub If Target.Value <> "" Then If Target.Value <> Target.Offset(-1, 0).Value Then Rows(myRow & ":" & myRow).Insert Shift:=xlShiftDown If Target.Address = "$A$4" Then Target.Offset(-1, 6).Value = Range("F2").Value Else myCell1 = Target.Offset(0, 6).End(xlUp).Offset(1, -1).Address myCell2 = Target.Offset(-1, 5).Address Target.Offset(-2, 6).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If End If Target.Offset(0, 1).Select End If ElseIf Target.Address = Range("D" & myRow).Address _ Or Target.Address = Range("E" & myRow).Address Then If myRow = 1 Then Exit Sub If Target.Column = 4 And Target.Offset(0, 1).Value <> "" Then If Target.Value = "" Then Target.Offset(0, 2).Value = Target.Offset(0, 1).Value * 0.75 Else Target.Offset(0, 2).Value = Target.Offset(0, 1).Value End If If Target.Offset(0, 3).End(xlDown).Address <> Cells(Rows.Count, 7).Address Then If Target.Offset(-1, 2).Value = "" Then myCell1 = Target.Offset(0, 2).Address Else myCell1 = Target.Offset(0, 2).End(xlUp).Address End If myCell2 = Range(myCell1).End(xlDown).Address Target.Offset(0, 3).End(xlDown).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If ElseIf Target.Column = 5 Then If Target.Offset(0, -1).Value = "" Then Target.Offset(0, 1).Value = Target.Value * 0.75 Else Target.Offset(0, 1).Value = Target.Value End If If Target.Offset(0, 2).End(xlDown).Address <> Cells(Rows.Count, 7).Address Then If Target.Offset(-1, 1).Value = "" Then myCell1 = Target.Offset(0, 1).Address Else myCell1 = Target.Offset(0, 1).End(xlUp).Address End If myCell2 = Range(myCell1).End(xlDown).Address Target.Offset(0, 2).End(xlDown).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If End If Set myRange = Cells(Rows.Count, 1).End(xlUp) If myRange.Offset(0, 1).Value = "" Then myRange.Offset(0, 1).Select ElseIf myRange.Offset(0, 5).Value <> "" Then myRange.Offset(1, 0).Select Else myRange.End(xlToRight).Offset(0, 1).Select End If End If End Sub お手数をおかけいたしますが、よろしくお願いいたします。

kazuhiko5681 · Answer

私の考えで、マクロを作ってみました。まず最初に、前回と同じ方法で、下記のコードを新規ブックのSheet1モジュールにコピー・ペーストして下さい。 Private Sub Worksheet_Activate() Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim myCell1 As String Dim myCell2 As String If Target.Column = 1 Then If Target.Address = "$A$1" Or Target.Address = "$A$2" Then Exit Sub Else If Target.Value = Target.Offset(-1, 0).Value Then Target.Offset(-1, 6).Value = "" Target.Offset(0, 6).Value = "" Else If Target.Offset(-1, 0).Value <> Target.Value Then If Target.Address = "$A$3" Then Target.Offset(-1, 6).Value = Range("F2").Value Else myCell1 = Target.Offset(0, 6).End(xlUp).Offset(1, -1).Address myCell2 = Target.Offset(-1, 5).Address Target.Offset(-1, 6).Value = Application.WorksheetFunction.Sum(Range(myCell1 & ":" & myCell2)) End If End If End If End If ElseIf Target.Column = 5 Then If Target.Value = "" Then Target.Offset(0, 1).Value = "" Target.Offset(0, 2).Value = "" Else If Target.Offset(0, -1).Value = "" Then Target.Offset(0, 1).Value = Target.Value * 0.75 Else Target.Offset(0, 1).Value = Target.Value End If If Target.Offset(1, -4).Value <> "" Then If Target.Offset(1, -4).Value <> Target.Offset(0, -4).Value Then myCell1 = Application.WorksheetFunction.Sum(Range("F2:" & Target.Offset(0, 1).Address)) myCell2 = Application.WorksheetFunction.Sum(Range("G2:" & Target.Offset(-1, 2).Address)) Target.Offset(0, 2).Value = myCell1 - myCell2 End If End If Target.Offset(1, -4).Select End If End If End Sub 今度は、ＶＢＥ画面の左上のThisWorkbookをダブルクリックし、ThisWorkbookのモジュールを開きます。そのモジュールに以下のコードをコピーペーストして下さい。 Private Sub Workbook_Open() ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Select End Sub 次のように操作してみてください。１.エクセル画面に戻り、１行目に項目名を入力。２.データーを入力してみて下さい。自動的に計算されて表が完成していきます。

エクセルのマクロ

こんばんわ。

こんばんは。

＃１４のものです。

この回答への補足

こんばんわ。

＃４のものです。

この回答への補足

＜もっと簡単に出来るのではないか＞

この回答への補足

こんにちは。

この回答への補足

こんばんわ。

この回答への補足

こんばんわ。

この回答への補足

私の考えで、マクロを作ってみました。

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

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

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

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