[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ＶＢＡ 品番が違ったら行挿入、平均値、標準偏差算出』（TBLR）
データの実績値を集計したいのですが処理後の表にするのにはＶＢＡでどうしたら良いのかご教授宜しくお願いします。
Windows7,Excel2016です。
Ｃ列の品番が違ったら、 1.行を挿入し、同じ品番のデータ数、 2.行挿入、同じ品番の各項目（Ｈ列からＲ列）の平均値 3.行挿入、同じ品番の各項目（Ｈ列からＲ列）の標準偏差 4.行挿入 5.見出しとして（A2：R4）をコピーして行挿入貼り付け ※4行目規格列は関数でＣ列の品番を参照し別シートの規格を呼び出すようになっています。
を繰り返したい
出来るだけ元データの形を乱したくないのでピボットテーブルは使わない方向でいきたいです。 品番は順番に並んでいます。宜しくお願いします。
元データ
A列 B列 C列 D列 Ｅ列 F列 G列 H列 I列 J列 K列 L列 M列 N列 O列 D列 Q列 R列
1
2 ○表題
3 番号1(抽出) 番号2(総) 品番 品物名 ロット 項目1 項目2 項目3 項目4 項目5 項目6 項目7 項目8 項目9 項目10 項目11 項目12 項目13
4 規格 ○○○ □□□ ○±△ □±△ ▽±△ ○±○ ○±□ ○±□ ▽±□ ○±△ ○±△ ○±△ □±○
5 2 4198 66212 α 121012 *** *** 3 20 100
6 67 4257 66212 α 121015 *** *** 3 20
7 33 4263 66213 β 121016 *** *** 4 10
8 80 4270 66213 β 121018 *** *** 4 10
9 83 4222 66214 γ 121125 *** *** 80 2 15 10
10 26 4282 66215 δ 121025 *** *** 3 9
︙
処理後
A列 B列 C列 D列 Ｅ列 F列 G列 H列 I列 J列 K列 L列 M列 N列 O列 D列 Q列 R列
1
2 ○表題
3 番号1(抽出) 番号2(総) 品番 品物名 ロット 項目1 項目2 項目3 項目4 項目5 項目6 項目7 項目8 項目9 項目10 項目11 項目12 項目13
4 規格 ○○○ □□□ ◎±△ □±△ ▽±△ ◎±○ ○±□ ◎±□ ▽±□ ○±△ ◎±△ ○±△ □±◎
5 2 4198 66212 α 121012 *** *** 3 20 100
6 67 4257 66212 α 121015 *** *** 3 20
7 データ数 2
8 平均 3 20 100
9 標準偏差 0 0 0
10
11 ○表題
12 番号1(抽出) 番号2(総) 品番 品物名 ロット 項目1 項目2 項目3 項目4 項目5 項目6 項目7 項目8 項目9 項目10 項目11 項目12 項目13
13 規格 ○○○ □□□ ○±▲ □±△ ▽±▲ ○±○ ○±◇ ○±□ ◇±□ ○±▲ ◎±◇ ○±▲ □±○
14 33 4263 66213 β 121016 *** *** 4 10
15 80 4270 66213 β 121018 *** *** 4 10
16 データ数 2
17 平均 4 10
18 標準偏差 0 0
19
20 ○表題
21 番号1(抽出) 番号2(総) 品番 品物名 ロット 項目1 項目2 項目3 項目4 項目5 項目6 項目7 項目8 項目9 項目10 項目11 項目12 項目13
22 規格 ○○○ □□□ ○±△ □±▽ ▽±▽ ◎±◎ ◎±□ ○±◇ ▽±◇ ○±△ ◎±▽ ○±▽ ◇±○
23 83 4222 66214 γ 121125 *** *** 80 2 15 10
24 データ数 1
25 平均 80 2 15 10
26 標準偏差 0 0 0 0
︙
＜ 使用 Excel：Excel2016、使用 OS：Windows7 ＞
1 品番「66212」を抽出して、処理後シートに貼付 2 処理後シートの最終行＋１に、データ数、平均、標準偏差を算出する数式を書き込む 3 品番「66213」を抽出して、処理後シートに貼付 4 処理後シートの最終行＋１に、データ数、平均、標準偏差を算出する数式を書き込む 5 品番「66214」を抽出して、処理後シートに貼付 6 処理後シートの最終行＋１に、データ数、平均、標準偏差を算出する数式を書き込む . . .
という処理を考えてみてはどうでしょうか？
提示されたデータだと品番が順序よく並んでいますが、実データでもソートがかかった状態なのでしょうか？
抽出する方法なら、ソートはかかってなくても処理可能とおもわれます。
（もこな２） 2019/08/16(金) 12:46
とりあえず 品番が変わったら行挿入するコードです
規格の数式が判らないので、そのままコピーしています データ数、平均、標準偏差の数式については、自動記録でもして、追加してみてください
Sub test4()
Dim myFrmSht As Worksheet
Dim myToSht As Worksheet
Dim myFrmRow As Long
Dim myToRowStart As Long
Dim myToRowEnd As Long
Set myFrmSht = ThisWorkbook.Worksheets("元データ")
Set myToSht = ThisWorkbook.Worksheets("処理後")
myToSht.Cells.Clear
myFrmSht.Rows(2).Resize(4).Copy myToSht.Rows(2).Resize(4)
myFrmRow = 5
myToRowStart = 5
myToRowEnd = 5
Do
If myFrmSht.Cells(myFrmRow, "C").Value = myFrmSht.Cells(myFrmRow + 1, "C").Value Then
myFrmRow = myFrmRow + 1
myToRowEnd = myToRowEnd + 1
myFrmSht.Rows(myFrmRow).Copy myToSht.Rows(myToRowEnd)
Else
myToSht.Cells(myToRowEnd + 1, "E").Value = "データ数"
myToSht.Cells(myToRowEnd + 2, "E").Value = "平均"
myToSht.Cells(myToRowEnd + 3, "E").Value = "標準偏差"
myToRowStart = myToRowEnd + 5
If Len(myFrmSht.Cells(myFrmRow + 1, "C").Value) = 0 Then Exit Do
myFrmSht.Rows(2).Resize(3).Copy myToSht.Rows(myToRowStart).Resize(3)
myToRowStart = myToRowStart + 3
myToRowEnd = myToRowStart
myFrmRow = myFrmRow + 1
myFrmSht.Rows(myFrmRow).Copy myToSht.Rows(myToRowStart)
End If
Loop
End Sub
（渡辺ひかる） 2019/08/16(金) 13:31
初めに2-4行の項目行の書式を太文字等にしておくと見やすくなるでしょう。
Sub test()
Dim HDR As Range, rng As Areas, i As Long
Set HDR = Rows("2:4")
Columns(1).Insert
With Range("d6", Range("d" & Rows.Count).End(xlUp)).Offset(, -3)
.Formula = "=if(d5<>d6,if(a5=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
.SpecialCells(2, 1).EntireRow.Insert
.SpecialCells(2, 2).EntireRow.Insert
.EntireColumn.Delete
End With
Set rng = Columns(1).SpecialCells(2, 1).Areas
For i = rng.Count To 1 Step -1
With rng(i)
.Offset(.Count).Resize(4).EntireRow.Insert
With .Offset(.Count).EntireRow.Resize(3)
.Columns("d").Value = [{"データ数";"平均";"標準偏差";""}]
.Range("e1").Value = rng(i).Count
.Range("h2:r2").Formula = "=average(" & rng(i).Columns("h").Address(0, 0) & ")"
.Range("h3:r3").Formula = "=stdev(" & rng(i).Columns("h").Address(0, 0) & ")"
End With
If i > 1 Then
HDR.Copy
.Offset(-1).EntireRow.Insert
End If
End With
Next
End Sub
（seiya） 2019/08/16(金) 14:09
頂きました案どれも実行できました。
VBA これまでの私の作成方法が悪いのか
頂いた案そのままでは半日かけても実行処理が終わらなかったので
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
︙︙ ︙
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
を初めと終わりに入れ、使わせて頂きました。
それでも処理が終わるのに数分はかかりますが、
実行できるようになりました。
重ね重ね、有難うございます。
（TBLR） 2019/08/17(土) 18:39
seiya様のコード暫く試用させて頂いてます。
下から5行目
.Offset(-1).EntireRow.Insert
偶にこの部分で1回だけでなく
2回ないし3回連続で[2-4行目]が張り付けられる場合があるのですが
どういった場合に連続で貼り付けされるのが
考えられるでしょうか。
過剰に貼りつけされたところは
消せばよいだけですが少し気になったので…
質問させて頂きます。
宜しければご教授お願い致します。
（TBLR） 2019/08/19(月) 20:32
Hummmm... いろいろな状況で試しましたが、その部分だけ複数回実行される現象は再現できません。 できれば、その現象が出るブックをどこかのサイトにアップしてもらえればわかるかも知れません。 （seiya） 2019/08/19(月) 21:05
Ahhhh
> .Offset(-1).EntireRow.Insert
を
.Rows(1).Offset(-1).EntireRow.Insert
に変更してください。
（seiya） 2019/08/19(月) 23:05
返信有難うございます！
ご指摘の部分変更したところ狙い通りの処理ができるようになりました。
今の私には残念ながら難解なコードです…
特に
コード前半部分の列を挿入してまた削除するまでの部分、
意味がまだ良く理解できていないのですが
この部分は何をしているのでしょうか？
お時間のある時にでもお返事頂ければ有難いです。
宜しくお願い致します。
（TBLR） 2019/08/20(火) 23:17
1) C列の 品番 の変わり目に空白行を挿入するために、A列に作業列を挿入してデータ全体を一列右にシフトする。 2) A列に数式を配してD列（品番列) の変わり目に当たる行に a 又は 1 を記す。 3) A列の数式を値に変換して、SpecialCells メソッドで該当行に空白行を挿入後 A列を削除。
Step Debug して確認してください。
VBEウィンドウを縮小して背後にエクセル画面が見えるような形にする。 コードのどの部分でもよいので一度クリックした後、F8キーを押下する毎にコードが一行実行されます。 同時にコードの行によっては背面にあるエクセル画面が変化するので、どのような動きをするか確認してください。 （seiya） 2019/08/21(水) 05:44
返信有難うございます。
仰る通りの操作で1行ずつ実行すると輪郭が見えてきました。
悩んでいた案件に回答を示して頂けたこと、
またここまで質問にお付きあい頂きましたこと、本当に有難うございました。
（TBLR） 2019/08/21(水) 21:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.