グループの最後の行に書式、計算式なども同じ行を追加するマクロを教えてもらえませんか。

Question

お忙しいところ、すいませんがよろしくお願いいたします。
グループの最後の行に書式、計算式なども同じ行を追加する

　　A　　　B　　　C　　D
1　A商品　単価　金額　合計
2　A商品　単価　金額　合計
3　　　　　　　　　　A商品合計
4　
5　B商品　単価　金額　合計
6　B商品　単価　金額　合計
7　　　　　　　　　　B商品合計

A商品を購入したら　3行目に行を追加してここに入力。
B商品を購入したら　7行目に行を追加してここに入力できるようにしたいと思います。
4行目は空白です。商品間は何行か空白としています。

Qchan1962 · Accepted Answer

＃６の追質について
表組みも変わっているし・・・
まぁ、改造も出来ていると言う事でしょうしコードも理解されたと言う事でしょうから、これだけで良いかな

Call r.CurrentRegion.Sort(Key1:=r.Offset(, 1), Order1:=xlAscending)

＃６のコードを基に表組みに合わせた回答です

＞グループの最後の行に書式、計算式なども同じ行を追加する
とは、内容が違いますので別スレにしてください。
（規約、マナー違反に牴触します）

Qchan1962 · Answer

こんばんは
＞一旦入れて、値を消すのですか？
その方法が簡単がと思います。
＞b商品の最後の行番号を取り出したいと思いますがこれも良くわかりません。

最後とは、挿入後？挿入前？
＃５のコードを書き直してみるので　確認してください
*（A列に区切りの空白セルがある）場合

Private Sub CommandButton1_Click()
Dim zaiko As String
Dim r As Range, C As Range
    zaiko = ListBox1.List(ListBox1.ListIndex, 0)
    With ActiveSheet
        Set r = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)) _
                .Find(What:=zaiko, LookIn:=xlValues, LookAt:=xlWhole, After:=Cells(Rows.Count, 1).End(xlUp))
    End With
    If Not r Is Nothing Then
        With r.End(xlDown)
            MsgBox .Row      'これ?
            .Resize(, 4).Copy
            .Offset(1).Insert Shift:=xlDown
            Application.CutCopyMode = False
            For Each C In .Offset(1, 1).Resize(1, 3)
                If Not C.HasFormula Then C.Value = ""
            Next
            MsgBox .End(xlDown).Row    ''これ?
        End With
    End If
End Sub

Qchan1962 · Answer

＃１＃２を回答した者です
他のご質問者様のご質問を見て　ご質問にある表組
（A列に区切りの空白セルがある）場合で
ユーザーフォームにボタンとリストボックスを設置した場合の参考コードです。

リストを作成するにあたり、Unique関数を使用していますので
Microsoft 365およびOffice 2021の　Excel　又はOffice Insiderに参加しているExcelが対象になります
Unique関数が使用できない場合は、
セル範囲を利用してリストを作るか
DictionaryやCollectionなどなどで作って下さい

ユーザーフォームのモジュールに
Private Sub CommandButton1_Click()
    Dim zaiko As String
    Dim r As Range
    zaiko = ListBox1.List(ListBox1.ListIndex, 0)
    With ActiveSheet
        Set r = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)) _
                .Find(What:=zaiko, LookIn:=xlValues, LookAt:=xlWhole, After:=Cells(Rows.Count, 1).End(xlUp))
    End With
    If Not r Is Nothing Then
        With r.End(xlDown)
            .Resize(, 4).Copy
            .Insert Shift:=xlDown
            Application.CutCopyMode = False
        End With
    End If
End Sub

Private Sub UserForm_Initialize()
Dim myList, i As Long
myList = Application.Unique(Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)))
For i = 1 To UBound(myList)
If myList(i, 1) <> "" Then ListBox1.AddItem myList(i, 1)
Next
End Sub

KenKen_SP · Answer

こんにちは。

ご質問の内容だとピボットテーブルを使うのが良いと思います。
商品別、月別などで簡単に集計できますよ。

キーワード： ピボットテーブル

小計欄を挿入するのは、データ加工の支障になります。

VBAの学習目的であったり、印刷の都合があるなどの
事情が無い限り、集計欄は行頭など邪魔にならない場所、
あるいは別シートなどがオススメです。

chonami · Answer

合計・空白行は入れず、商品毎に並べ替えして小計機能ではダメなんでしょうか？

Qchan1962 · Answer

私が回答できるかは分かりませんが
作成されたフォーム要件を掲示が必要です。
また、A商品は複数存在すると理解していますが、どこのセルを対象にするのかなど要件を提示する必要もあります

更に記せば、作成されたフォームのリストボックスの基データを
何処から参照するのか（商品リスト）の要件説明、重複データに対する処理、該当データがない場合の要件などを示す必要があります。

現在どこまで出来ているのでしょう？
思いついてすぐに質問したと言う事でしょうか？
出来上がるにつけ、次の思い付きで作ると言う事でしょうか・・・

しっかり行いたい処理を組立、自身で作成し分からない所を絞り
具体的にコードなどを示してご質問を作成される方が良いと思います

不要なやり取りが必要になる事になりますので
ご確認くださいね

Qchan1962 · Answer

こんにちは
＞商品名は入力して検索をしたいと思います。
４列分で検索結果セルが選択されているとの解釈で良いなら
Sub test()
    Selection.Resize(, 4).Copy
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub

A商品郡、商品名最後の行なら
    Range("A1").End(xlDown).Resize(, 4).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

検索自体をVBAで行いたい場合は、キーワード入力要件が必要です

グループの最後の行に書式、計算式なども同じ行を追加するマクロを教えてもらえませんか。

＃６の追質について

こんばんは

＃１＃２を回答した者です

こんにちは。

合計・空白行は入れず、商品毎に並べ替えして小計機能ではダメなんでしょうか？

私が回答できるかは分かりませんが

こんにちは

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

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

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

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