エクセルの表の並べ替え(データの入れ替え）について

質問

こんにちは。
いつもお世話になっております。

エクセルで相談があるのですが、
A～Eまで項目があるデータを並べ替えというか、表示を
変えたいのですが、どのようにしたらいいのかわからずお知恵を
お借り出来たら幸いです。

A　　B　　　C　　　D　　E　　
No.　名前　　金額　担当　内容
1　田仲商店　300　鈴木　みかん
・
・

というようなデータが1万件ほどあります。
No.は連番なので重複しません
名前は重複があります。最大20件でした
担当も重複があります。
内容も重複があります。

やりたいことは、別のシートに
B列の名前ごとに金額をまとめたい。
かつ、内容（と出来れば金額も）を全てわかるようにしたい。

出来上がりイメージ
名前　　　合計金額　内容1　金額1　内容2　金額2　・・・・・
田仲商店　1800　　　みかん　 300　りんご 　200　いちご 800　きうい 500
山田店　　1000　　　いちご　1000

または

名前　　　合計金額　内容1　　内容2　・・・・
田仲商店　1800　　　みかん　りんご　いちご　きうい
　　　　　　　　　　　300　　200　　　800　　500
山田店　　1000　　　いちご
　　　　　　　　　　　1000　
という感じです。

SUMIFで金額の統合までは出来るのですが、それ以外の部分が
私の知識だとまったく届きません。

大変恐縮ですが、教えていただけると幸いです。
宜しくお願い致します。

回答No.3

kagakusuki · ベストアンサー

今仮に、どちらのシートも「名前」等の項目名が入力されている行が1行目であるものとします。
　また、元データの表があるシートがSheet1であり、Sheet3のA列を作業列として使用して、Sheet2に結果を表示させるものとします。

　その場合、まずSheet2の1行目に「名前」、「合計金額」、「内容1」、「金額1」、「内容2」、「金額2」・・・・・という具合に各項目名を入力して下さい。

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

=Sheet1!$A$1&"◆1"

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

=IF(INDEX(Sheet1!$B:$B,ROW())="","",INDEX(Sheet1!$B:$B,ROW())&"◆"&COUNTIF(Sheet1!$B$1:INDEX(Sheet1!$B:$B,ROW()),INDEX(Sheet1!$B:$B,ROW())))

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

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

=IF(A1="","",IF(ROWS(A$1:A2)>COUNTIF(Sheet3!$A:$A,"*?◆1"),"",INDEX(Sheet1!$B:$B,MATCH("*?◆1",INDEX(Sheet3!$A:$A,MATCH(A1&"◆1",Sheet3!$A:$A,0)+1):INDEX(Sheet3!$A:$A,MATCH(9E+307,Sheet1!$A:$A)),0)+MATCH(A1&"◆1",Sheet3!$A:$A,0))))

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

=IF($A2="","",SUMIF(Sheet1!$B:$B,$A2,Sheet1!$C:$C))

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

=IF($A2="","",IF(ISERROR(1/(INDEX(CHOOSE(MOD(COLUMNS($C:C),2)+1,Sheet1!$C:$C,Sheet1!$E:$E),MATCH($A2&"◆"&INT((COLUMN()-COLUMN($C:$C))/2+1),Sheet3!$A:$A,0))<>"")),"",INDEX(CHOOSE(MOD(COLUMNS($C:C),2)+1,Sheet1!$C:$C,Sheet1!$E:$E),MATCH($A2&"◆"&INT((COLUMN()-COLUMN($C:$C))/2+1),Sheet3!$A:$A,0))))

　次に、Sheet2のC2セルをコピーして、Sheet2のD2セル～「Sheet2の表において最も右側にある金額を表示させる列の2行目のセル」のセル範囲に貼り付けて下さい。
　次に、Sheet2の2行目全体をコピーして、Sheet2の3行目以下に貼り付けて下さい。

　以上です。

お礼

ありがとうございました！出来ました。
配列関数やINDEX関数はどうも苦手なので、
勉強になりました。
まだ同じものを作れるレベルまでは難しいですが
勉強していきたいと思います。
ありがとうございます。

回答No.5

kagakusuki

今仮に、どちらのシートも「名前」等の項目名が入力されている行が1行目であるものとします。
　また、元データの表があるシートはSheet1であり、結果を表示させるシートはSheet2であるものとします。

Sub QNo9258870_エクセルの表の並べ替え_データの入れ替え_について()

Const DataSheetName As String = "Sheet1" '元データの表があるシートのシート名
Const OutputSheetName As String = "Sheet2" '出力先の表があるシートのシート名
Const FirstRow0 As Long = 2 '元データの表があるシートにおいて実際のデータが入力されている最初の行の行番号
Const FirstRow1 As Long = 2 '出力先の表があるシートにおいて実際のデータを書き込む最初の行の行番号
Const NameColumn0 As String = "B" '元データの表があるシートにおいて名前が入力されている列の列番号
Const NameColumn1 As String = "A" '出力先の表があるシートにおいて名前を書き込む列の列番号
Const AmountColumn0 As String = "C" '元データの表があるシートにおいて金額が入力されている列の列番号
Const AmountColumnT As String = "B" '出力先の表があるシートにおいて合計金額を書き込む列の列番号
Const ContentsColumn As String = "E" '元データの表があるシートにおいて内容が入力されている列の列番号
Dim DataSheet As Worksheet, OutputSheet As Worksheet _
, LastRow0 As Long, LastRow1 As Long, OutputRow As Long _
, buf(2) As Variant, i As Long, j As Long, k As Long

For i = 0 To 1
If IsError(Evaluate("ROW('" & Array(DataSheetName, OutputSheetName)(i) & "'!A1)")) Then
MsgBox Array("元データが入力されている", "処理結果を出力するための")(i) _
& "シートとして設定されている" & vbCrLf & vbCrLf _
& Array(DataSheetName, OutputSheetName)(i) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Next i
Set DataSheet = Sheets(DataSheetName)
Set OutputSheet = Sheets(OutputSheetName)

LastRow0 = Range(NameColumn0 & Rows.Count).End(xlUp).row
If LastRow0 < FirstRow0 Then
MsgBox "処理すべきデータがありません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

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

With OutputSheet
.Range(NameColumn1 & FirstRow1 & ":" _
& .Cells.SpecialCells(xlCellTypeLastCell).Address).ClearContents
End With

For i = FirstRow0 To LastRow0
With DataSheet
buf(0) = .Range(NameColumn0 & i).Value
buf(1) = .Range(ContentsColumn & i).Value
buf(2) = .Range(AmountColumn0 & i).Value
End With
If buf(0) <> "" Then
With OutputSheet
If LastRow1 = 0 Then
j = FirstRow1
Else
For j = FirstRow1 To LastRow1
If OutputSheet.Range(NameColumn1 & j).Value = buf(0) Then Exit For
Next j
End If
If j > LastRow1 Then
.Range(NameColumn1 & j).Value = buf(0)
LastRow1 = j
End If
With .Range(AmountColumnT & j)
.Value = WorksheetFunction.Sum(.Offset(), DataSheet.Range(AmountColumn0 & i))
End With
For k = 1 To UBound(buf)
With .Cells(j, Columns.Count).End(xlToLeft).Offset(0, 1)
.Value = buf(k)
If k = 2 Then .NumberFormatLocal = "\#,##0;\-#,##0"
End With
Next k
End With
End If
Next i

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

ありがとうございます。

どの方法を使っても出来ました。
本当にありがとうございます。
色々な方法で出来ることが分かり、本当に助かっております。
ありがとうございます。

お礼が遅くなり申し訳ありませんでした。
ありがとうございます。

回答No.4

ushi2015

こんばんは
Dictionaryとか配列とか色々なコードが考えられますけど、
手作業をマクロ化した感じのコードにしてみました。
Alt+F11キーでVBE画面を表示し標準モジュールを挿入し下記コードをコピペ
して、コードの中の部分をクリックし、F8キーで1行ずつステップ実行して
変化を見ていくと、どんな処理をしているか分かります。
Sub test()
　　Dim i As Long
　　Dim r As Range
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim sht As Worksheet
　　Dim pvc As PivotCache
　　Dim pvt As PivotTable

　　Application.ScreenUpdating = False

　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set sht = Worksheets.Add
　　sh2.UsedRange.ClearContents

　　Set pvc = ActiveWorkbook.PivotCaches.Create( _
　　　　SourceType:=xlDatabase, _
　　　　SourceData:=sh1.Range("A1").CurrentRegion, _
　　　　Version:=xlPivotTableVersion12)

　　With sht
　　　　Set pvt = pvc.CreatePivotTable( _
　　　　　　TableDestination:=.Range("A1"), _
　　　　　　TableName:="ピボットテーブル1", _
　　　　　　DefaultVersion:=xlPivotTableVersion12)

　　　　With pvt.PivotFields("名前")
　　　　　　.Orientation = xlRowField
　　　　　　.Position = 1
　　　　End With

　　　　pvt.AddDataField pvt.PivotFields("金額"), "合計金額", xlSum
　　　　pvt.CompactLayoutRowHeader = "名前"

　　　　.Range("A1").CurrentRegion.Copy
　　　　sh2.Range("A1").PasteSpecial _
　　　　　　Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　　　:=False, Transpose:=False

　　　　.UsedRange.Delete
　　　　.Range("A1") = sh1.Range("B1")
　　　　.Range("B1") = sh1.Range("E1")
　　　　sh1.Range("A1").CurrentRegion.AdvancedFilter _
　　　　　　Action:=xlFilterCopy, _
　　　　　　CopyToRange:=.Range("A1:B1"), _
　　　　　　Unique:=True

　　　　For Each r In _
　　　　　　sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp).Offset(-1))
　　　　　　.Range("A1").CurrentRegion.AutoFilter _
　　　　　　　　Field:=1, _
　　　　　　　　Criteria1:="=" & r.Value, _
　　　　　　　　Operator:=xlAnd
　　　　　　.AutoFilter.Range.Columns(2).Copy
　　　　　　sh2.Range("C" & r.Row).PasteSpecial _
　　　　　　　　Paste:=xlPasteAll, Operation:=xlNone, _
　　　　　　　　SkipBlanks:=False, Transpose:=True
　　　　Next
　　End With

　　Application.DisplayAlerts = False
　　sht.Delete
　　Application.DisplayAlerts = True

　　With sh2
　　　　.Range("C:C").Delete
　　　　For i = .UsedRange.Columns.Count To 4 Step -1
　　　　　　.Columns(i).Insert
　　　　Next
　　　　For i = 1 To .UsedRange.Columns.Count + 1 Step 2
　　　　　　.Range("C2", .Range("C" & Rows.Count).End(xlUp)).Offset(, i).FormulaR1C1 = _
　　　　　　　　"=IF(Sheet2!RC[-1]="""",""""," & _
　　　　　　　　"SUMIFS(Sheet1!C3,Sheet1!C2,Sheet2!RC1,Sheet1!C5,Sheet2!RC[-1]))"
　　　　Next
　　　　.Range("C1:D1").Value = Array("内容1", "金額1")
　　　　.Range("C1:D1").AutoFill _
　　　　　　Destination:=.Range("C1").Resize(, .UsedRange.Columns.Count - 4), _
　　　　　　Type:=xlFillDefault
　　　　.Range("A" & Rows.Count).End(xlUp).EntireRow.Delete
　　End With

　　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。VBAは、マクロを記録して少し読み解ける
レベルなので（ほぼ初心者です）F8でステップ実行ができるなんて
驚きでした！

今後の勉強になります！

色々な方法で出来ることが分かり、本当に助かっております。
ありがとうございます。

お礼が遅くなり申し訳ありませんでした。
ありがとうございます。

回答No.2

ushi2015

こんにちは
内容が1000種類も有るとダメですね。
マクロでも良ければ考えますけど、数式だとちょっと面倒なので
他の方にお任せします。

補足

ありがとうございます。私のピボットの組み方の問題かと
思いました…。
マクロでもOKです。
もし方法があればお願いいたします！

回答No.1

ushi2015

こんにちは
2番目の表で良ければ、ピボットテーブルですぐ出来ますよ。
リボンの挿入タブのピボットテーブルのボタンをクリックして試して下さい。

補足

回答ありがとうございます。
作ってみましたが、内容のデータが、横に何千件も出てしまうのですが…。
内容の種類は1000ほどあり、全てのお店で全ての内容が
あるわけではなく（一つのお店内での重複数は最大で20種類）なので、
出来れば左詰めにしたいのですが何か方法はありますでしょうか？（涙）

ピボットの組み方が悪いんでしょうか？
行ラベルに名前、列ラベルに内容、値に金額の合計を入れております。