項目別に合計数入力

質問

シート１の表－１にA~C列に文字とD,E列に数値が入力されておりシート２の表－２にA,B,C列の文字が同一行であれば１行とし違えば行を追加し同一行はD,E列の数値を加算していきたいのですがどなたかVBAコードか関数の解る方宜しくお願いします。

回答No.4

kkkkkm · ベストアンサー

> ３列重複行の削除の方法（VBA,関数）はわかりませんか？

Excel2007以降でしたら以下のコードになります
コピー貼り付け後、表ー2をアクティブな状態にして
ActiveSheet.Range("$C$4:$E$15").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

Excel2003まで含むと以下になります。こちらの場合、範囲は見出し行も操作対象になります。また、重複を除いたデータを貼り付けますので先にコピー貼り付けは不要です
Sheets("表ー1").Range("$B$3:$D$15").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("表ー2").Range("$C$3"), _
Unique:=True

回答No.9

bunjii

>VBAコードか関数の解る方宜しくお願いします。
VBAコードを他人に頼ることはお勧めできません。
自分でプログラミングしても後日の仕様変更時に修正困難となることもありますので、他人がコーディングしたものを修正することは不可能に近いでしょう。
質問に添付の画像と質問文ではあなたの目的が分かり難い状態です。
「シート１」とは「Sheet1」と読み替えて良いでしょうか？
「表ー１」、「表ー２」とされているセルは全く無意味なものと考えられます。
「表ー１」のB3:F3にあるA～Eの文字は元データの列記号を表すものと考えてよいでしょうか？
また、「表ー２」のA～Eの文字も「表ー１」と同様で良いのでしょうか？
あなたが知りたいことはSheet2のA、B、C列の組み合わせで重複行を除く方法ですか？
D列とE列の集計方法はSUMIFS関数で可能になりますので容易に解決できるでしょう。
Sheet1の元データから集計用のSheet2のA～C列を作成するにはSheet1のA～C列をSheet2へコピペしてSheet2の「データ」タブの「重複の削除」で簡単にできます。
同等のことを関数で処理するには作業用の列を使うと分かり易くなります。
Sheet1のG列を作業用にするとき
G1=IF(COUNTIFS(A$1:A1,A1,B$1:B1,B1,C$1:C1,C1)=1,ROW(),"")
下へ必要数コピペしてSheet2の数式から参照します。
Sheet2のA1セルへ次の数式を設定して、右へC1セルまでコピペします。
更に、A1:C1を選択して下へ必要数コピペすればよいでしょう。
=IFERROR(INDEX(Sheet1!A$1:A$15,SMALL(Sheet1!$G$1:$G15,ROWS(A$1:A1))),"")
Sheet2のD列とE列の集計にはSUMIFS関数を使います。
D1=SUMIFS(Sheet1!D$1:D$15,Sheet1!$A$1:$A$15,$A1,Sheet1!$B$1:$B$15,$B1,Sheet1!$C$1:$C$15,$C1)
D1セルをE1セルへコピペし、D1:E1を選択して下へ必要数コピペすれば目的に適うでしょう。
添付画像はExcel 2013で検証した結果です。Excel 2007以降のバージョンで再現できるはずです。
尚、関数で集計用のSheet2を作成したときはA列からC列の配置を昇順または降順に整列できませんので、元データのSheet1を整列してください。

お礼

ありがとうございます。勉強になりました。

回答No.8

kagakusuki

回答No.7です。

　済みません。先ほど回答したVBAの構文の中に、バグとまでは言えないものの、将来的に使用するシートのシート名を変更するようなことがあった場合、バグが生じてしまう原因となる恐れがある箇所がありましたので、修正版のVBAを回答しなおします。

Sub QNo9218228_項目別に合計数入力()

Const ItemRow1 = 3 '元データの表において項目名が入力されている行
Const ItemRow2 = 3 '新たに作成する表において項目名が入力されている行
Dim i As Long, SheetName(1) As String, MySheet(1) As Worksheet, _
Column1 As Variant, Column2 As Variant, LastRow(1) As Long

SheetName(0) = "Sheet69" '元データの表が存在するシートのシート名
SheetName(1) = "Sheet69 (2)" '新たに表を作成するシートのシート名
Column1 = Array("B", "C", "D", "E", "F") '元データの表が使用している列の列番号
Column2 = Array("C", "D", "E", "F", "G") '新たに作成する表が使用する列の列番号

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

For i = 0 To 1
If IsError(Evaluate("ROW('" & SheetName(i) & "'!A1)")) Then
If i = 1 Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName(1)
Else
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & SheetName(0) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
GoTo labelE
End If
End If
Set MySheet(i) = Sheets(SheetName(i))
Next i

With MySheet(0)
LastRow(0) = .Range(Column1(0) & Rows.Count).End(xlUp).row
If LastRow(0) <= ItemRow1 Then
MsgBox "処理すべき元データが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If
MySheet(1).Range(Column2(0) & ItemRow2 & ":" & Column2(4) _
& MySheet(1).Cells.SpecialCells(xlCellTypeLastCell).row).Clear
With .Range(Column1(0) & ItemRow1 & ":" & Column1(2) & LastRow(0))
MySheet(1).Range(Column2(0) & ItemRow2) _
.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End With

With MySheet(1)
.Range(Column2(0) & ItemRow2 & ":" & Column2(2) & LastRow(0)) _
.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
LastRow(1) = .Range(Column2(0) & Rows.Count).End(xlUp).row
With .Sort
With .SortFields
.Clear
For i = 0 To 2
.Add Key:=Range(Column2(i) & ItemRow2 & ":" & Column2(i) & LastRow(1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
MySheet(1).Columns(Column2(i)).ColumnWidth _
= MySheet(0).Columns(Column1(i)).ColumnWidth
Next i
End With
.SetRange Range(Column2(0) & ItemRow2 & ":" & Column2(2) & LastRow(1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

.Range(Column2(3) & ItemRow2 & ":" & Column2(4) & ItemRow2).Value _
= MySheet(0).Range(Column1(3) & ItemRow1 & ":" & Column1(4) & ItemRow1).Value
With .Range(Column2(3) & ItemRow2 + 1 & ":" & Column2(4) & LastRow(1))
.FormulaR1C1 = "=SUMIFS(" & SheetName(0) & "!C[" & Columns(Column1(3)).column _
- Columns(Column2(3)).column & "]," & SheetName(0) & "!C2,RC3," _
& SheetName(0) & "!C3,RC4," & SheetName(0) & "!C4,RC5)"
.Parent.Calculate
.Value = .Value
.EntireColumn.AutoFit
End With

With .Range(Column2(0) & ItemRow2 & ":" & Column2(4) & LastRow(1))
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Resize(1, .Columns.Count).HorizontalAlignment = xlCenter
End With
.Activate
End With

labelE:
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

回答No.7

kagakusuki

下記のVBAマクロは、元データが存在しなった場合にはその旨を通知した上でマクロの実行を中断する事でエラーを回避し、表－2を作成するためのSheet2が存在しなかった場合には自動でSheet2を追加し、Sheet2のC列～G列の3行目以下に古いデータが存在している場合には、その古いデータを自動的に削除し、項目A～Cの表示順序を昇順に並べ替えた上で、御要望の通り表－2の項目A～Cの重複箇所を無くし、項目D～Eの欄の所に項目A～Cの違いごとの合計値を書き込む様になっております。
　加えて、罫線の設定を行い、A～Eの項目欄のセルの表示を中央揃えにし、列幅の調整もついでに行う様になっております。

Sub QNo9218228_項目別に合計数入力()

Const ItemRow1 = 3 '元データの表において項目名が入力されている行
Const ItemRow2 = 3 '新たに作成する表において項目名が入力されている行
Dim i As Long, SheetName(1) As String, MySheet(1) As Worksheet, _
Column1 As Variant, Column2 As Variant, LastRow(1) As Long

SheetName(0) = "Sheet1" '元データの表が存在するシートのシート名
SheetName(1) = "Sheet2" '新たに表を作成するシートのシート名
Column1 = Array("B", "C", "D", "E", "F") '元データの表が使用している列の列番号
Column2 = Array("C", "D", "E", "F", "G") '新たに作成する表が使用する列の列番号

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

For i = 0 To 1
If IsError(Evaluate("ROW('" & SheetName(i) & "'!A1)")) Then
If i = 1 Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName(1)
Else
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & SheetName(0) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
GoTo labelE
End If
End If
Set MySheet(i) = Sheets(SheetName(i))
Next i

With MySheet(0)
LastRow(0) = .Range(Column1(0) & Rows.Count).End(xlUp).Row
If LastRow(0) <= ItemRow1 Then
MsgBox "処理すべき元データが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
GoTo labelE
End If
MySheet(1).Range(Column2(0) & ItemRow2 & ":" & Column2(4) _
& MySheet(1).Cells.SpecialCells(xlCellTypeLastCell).Row).Clear
With .Range(Column1(0) & ItemRow1 & ":" & Column1(2) & LastRow(0))
MySheet(1).Range(Column2(0) & ItemRow2) _
.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End With

With MySheet(1)
.Range(Column2(0) & ItemRow2 & ":" & Column2(2) & LastRow(0)) _
.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
LastRow(1) = .Range(Column2(0) & Rows.Count).End(xlUp).Row
With .Sort
With .SortFields
.Clear
For i = 0 To 2
.Add Key:=Range(Column2(i) & ItemRow2 & ":" & Column2(i) & LastRow(1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
MySheet(1).Columns(Column2(i)).ColumnWidth _
= MySheet(0).Columns(Column1(i)).ColumnWidth
Next i
End With
.SetRange Range(Column2(0) & ItemRow2 & ":" & Column2(2) & LastRow(1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

.Range(Column2(3) & ItemRow2 & ":" & Column2(4) & ItemRow2).Value _
= MySheet(0).Range(Column1(3) & ItemRow1 & ":" & Column1(4) & ItemRow1).Value
With .Range(Column2(3) & ItemRow2 + 1 & ":" & Column2(4) & LastRow(1))
.FormulaR1C1 = "=SUMIFS(Sheet1!C[" & Columns(Column1(3)).Column _
- Columns(Column2(3)).Column & "],Sheet1!C2,RC3,Sheet1!C3,RC4,Sheet1!C4,RC5)"
.Parent.Calculate
.Value = .Value
.EntireColumn.AutoFit
End With

With .Range(Column2(0) & ItemRow2 & ":" & Column2(4) & LastRow(1))
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Resize(1, .Columns.Count).HorizontalAlignment = xlCenter
End With
.Activate
End With

labelE:
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

ありがとうございます。勉強になりました。

回答No.6

kagakusuki

回答No.5です。
　回答No.5の方法では、表－２における項目A～Cの表示される順番が昇順になる様に並べ替えて表示する方法でしたが、もし項目A～Cが昇順でなくとも良いという場合には、作業列を1列だけで済ます事も出来ます。

　　まず、Sheet3のA4セルに次の関数を入力して下さい。

=IF(OR(INDEX(Sheet1!$B:$B,ROW())<>"",INDEX(Sheet1!$C:$C,ROW())<>"",INDEX(Sheet1!$D:$D,ROW())<>"",COUNT(INDEX(Sheet1!$E:$F,ROW()))=2),IF(COUNTIFS(Sheet1!$B$3:INDEX(Sheet1!$B:$B,ROW()),INDEX(Sheet1!$B:$B,ROW()),Sheet1!$C$3:INDEX(Sheet1!$C:$C,ROW()),INDEX(Sheet1!$C:$C,ROW()),Sheet1!$D$3:INDEX(Sheet1!$D:$D,ROW()),INDEX(Sheet1!$D:$D,ROW()))=1,ROW(),""),"")

　次に、Sheet3のA4セルをコピーして、Sheet3のA5以下に貼り付けて下さい。

　次に、Sheet2のC4セルに次の関数を入力して下さい。

=IF(ROW()-ROW(C$3)>COUNT(Sheet3!$A:$A),"",INDEX(Sheet1!$B:$D,SMALL(Sheet3!$A:$A,ROW()-ROW(C$3)),COLUMNS($C:C)))

　次に、Sheet2のF4セルに次の関数を入力して下さい。(回答No.5のものと同じ式)

=IF($C4="","",SUMIFS(Sheet1!$E:$E,Sheet1!$B:$B,$C4,Sheet1!$C:$C,$D4,Sheet1!$D:$D,$E4))

　次に、Sheet2のG4セルに次の関数を入力して下さい。(回答No.5のものと同じ式)

=IF($C4="","",SUMIFS(Sheet1!$F:$F,Sheet1!$B:$B,$C4,Sheet1!$C:$C,$D4,Sheet1!$D:$D,$E4))

　次に、Sheet2のC4セルをコピーして、Sheet2のD4～E4のセル範囲に貼り付けて下さい。
　次に、Sheet2のC4～G4のセル範囲コピーして、Sheet2のC列～G列の5行目以下に貼り付けて下さい。

　以上です。

お礼

ありがとうございます。勉強になりました。

回答No.5

kagakusuki

今仮に、Sheet3のA列とB列を差行列として使用するものとします。

　まず、Sheet3のA4セルに次の関数を入力して下さい。

=IF(OR(INDEX(Sheet1!$B:$B,ROW())<>"",INDEX(Sheet1!$C:$C,ROW())<>"",INDEX(Sheet1!$D:$D,ROW())<>"",COUNT(INDEX(Sheet1!$E:$F,ROW()))=2),IF(COUNTIFS(Sheet1!$B$3:INDEX(Sheet1!$B:$B,ROW()),INDEX(Sheet1!$B:$B,ROW()),Sheet1!$C$3:INDEX(Sheet1!$C:$C,ROW()),INDEX(Sheet1!$C:$C,ROW()),Sheet1!$D$3:INDEX(Sheet1!$D:$D,ROW()),INDEX(Sheet1!$D:$D,ROW()))=1,"!"&RIGHT("!!!!!"&INDEX(Sheet1!$B:$B,ROW()),5)&RIGHT("!!!!!"&INDEX(Sheet1!$C:$C,ROW()),5)&RIGHT("!!!!!"&INDEX(Sheet1!$D:$D,ROW()),5),""),"")

　次に、Sheet3のB4セルに次の関数を入力して下さい。

=IF($A4="","",COUNTIF($A:$A,"<"&$A4)-COUNTIF($A:$A,"<!")+1)

　次に、Sheet3のA4～B4のセル範囲をコピーして、Sheet3のA列～B列の5行目以下に貼り付けて下さい。

　次に、Sheet2のC4セルに次の関数を入力して下さい。

=IF(ROW()-ROW(C$3)>COUNT(Sheet3!$B:$B),"",INDEX(Sheet1!$B:$D,MATCH(ROW()-ROW(C$3),Sheet3!$B:$B,0),COLUMNS($C:C)))

　次に、Sheet2のF4セルに次の関数を入力して下さい。

=IF($C4="","",SUMIFS(Sheet1!$E:$E,Sheet1!$B:$B,$C4,Sheet1!$C:$C,$D4,Sheet1!$D:$D,$E4))

　次に、Sheet2のG4セルに次の関数を入力して下さい。

=IF($C4="","",SUMIFS(Sheet1!$F:$F,Sheet1!$B:$B,$C4,Sheet1!$C:$C,$D4,Sheet1!$D:$D,$E4))

　次に、Sheet2のC4セルをコピーして、Sheet2のD4～E4のセル範囲に貼り付けて下さい。
　次に、Sheet2のC4～G4のセル範囲コピーして、Sheet2のC列～G列の5行目以下に貼り付けて下さい。

　以上です。

回答No.3

kkkkkm

No2です。補足です。

式の中の表ー1は実際の表ー1のシート名に変更してください。
また、マクロの記録は表ー2のシートを表示して記録を開始してから表ー1のシートを選択してNo2の手順を行ってください。

補足

ありがとうございます。３列重複行の削除の方法（VBA,関数）はわかりませんか？

回答No.2

kkkkkm

表-1のB4からD15までコピーして表-2のC4に貼り付けます。
その後表-2のC4からE15を選択して重複の削除をします。
表-2のF4に
=SUMPRODUCT((表ー1!$B$4:$B$15=$C4)*(表ー1!$C$4:$C$15=$D4)*(表ー1!$D$4:$D$15=$E4)*表ー1!E$4:E$15)
と入力してF列とG列にコピーします。

上記の操作をマクロの記録で記録させればVBAコードが出来上がります。
行数が不確定の場合には15行目までを100行目などにして多めにコピーして貼り付けした操作を記録してください。
式の中の15はコピー範囲を100行目にした場合100に変更してください。

お礼

ありがとうございます。助かりました。

回答No.1

mshr1962

VBAや関数使うより、ピボットテーブルの方が早いし、簡単です。

・ピボットテーブルの使い方
http://allabout.co.jp/gm/gc/297727/