エクセルやアクセスでこんなことできませんか。

質問

現在以下のように雑誌名と記事のカテゴリと概要を一覧にしてエクセルにまとめています。

　＜雑誌名＞　　　＜記事カテゴリ＞　　＜記事の概要＞
日経新聞　　　　　　　政治　　　　　　　　記事１
FRIDAY　　　　　　　　芸能　　　　　　　　記事２
日経コンピュータ　　　IT　　　　　　　　　記事３
日経新聞　　　　　　　政治　　　　　　　　記事４
日経コンピュータ　　　政治　　　　　　　　記事５
　・　　　　　　　　　・　　　　　　　　　　・
　・　　　　　　　　　・　　　　　　　　　　・

この一覧を利用して、以下のように表示を変えたいのです。

　　　　　　　　　　　　|　　　政治　　　|　　芸能　　　　|　　　IT
----------------|-----------|------------|------------
日経新聞　　　　　　|　　記事１　　　|　　　　　　　　　|
　　　　　　　　　　　　|　　記事４　　　|　　　　　　　　　|
----------------|-----------|------------|-------------
FRIDAY　　　　　　　|　　　　　　　　　|　　記事２　　　|
----------------|-----------|------------|-------------
日経コンピュータ　|　　　記事５　　|　　　　　　　　　|　　記事３
----------------|-----------|------------|-------------

私もいろいろ考えてやってみたのですが上手い方法が見つかりません。どなたか詳しい方教えていただけないでしょうか。エクセルではなくアクセスを使う方法でも構いません。

ちなみに、アクセスのピポットテーブルビューを使うと、上記のように表示はできたのですが、ただ「表示」ができるだけで、その表示のまま外出し（エクセルなどにエクスポート）ができませんでした。

一覧にしている記事が多いため、一つ一つ動かして表示を変えるのはすごく時間がかかってしまうため、困っています。

よろしくお願いします。

回答No.2

mitarashi · ベストアンサー

VBAでやる例です。Sheet1に元データがあるとして、Sheet2に分類して書き出します。A列は結合セルになっているとしています。少数のデータでしか検証できておりませんが、ご参考まで。
Sub test()
Dim magazineDic As Object, categoryDic As Object
Dim i As Long
Dim mykey As Variant

Sheets(1).Activate
'重複カットしたリスト取得
Set magazineDic = CreateObject("Scripting.Dictionary")
Set categoryDic = CreateObject("Scripting.Dictionary")
For i = 2 To Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
If Not magazineDic.exists(Cells(i, 1).Value) Then
magazineDic.Add Cells(i, 1).Value, ""
End If
Next i
For i = 2 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row
If Not categoryDic.exists(Cells(i, 2).Value) Then
categoryDic.Add Cells(i, 2).Value, ""
End If
Next i
'見出し転記
Sheets(2).Cells.Clear
mykey = magazineDic.keys
For i = 0 To magazineDic.Count - 1
Sheets(2).Cells(i + 2, 1).Value = mykey(i)
Next i
mykey = categoryDic.keys
For i = 0 To categoryDic.Count - 1
Sheets(2).Cells(1, i + 2).Value = mykey(i)
Next i
'データ転記
For i = 2 To Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Call setValue(magazineNo(Cells(i, 1).Value, magazineDic), categoryNo(Cells(i, 2).Value, categoryDic), Cells(i, 3).Value)
Next i
Set magazineDic = Nothing
Set categoryDic = Nothing
End Sub

Private Sub setValue(magazineNo As Long, categoryNo As Long, myValue As Variant)
Dim myCell As Range
Dim i As Long, j As Long
Dim mergeRowCount
Dim hasEmptyFlag As Boolean
Dim indexCell As Range

With Sheets(2)
Set myCell = .Range("a1")
'手動で↓キーを押した時と同じ動作をさせるため1個ずつ下側にオフセットしている
For i = 1 To magazineNo
Set myCell = myCell.Offset(1, 0)
Next i
Set indexCell = myCell
mergeRowCount = myCell.MergeArea.Cells.Count
Set myCell = myCell.Offset(, categoryNo)
For j = 0 To mergeRowCount - 1
If myCell.Value = "" Then
myCell.Value = myValue
hasEmptyFlag = True
Else
Set myCell = myCell.Offset(1, 0)
End If
Next j
'未記入のセルが無ければ、1行追加
If hasEmptyFlag = False Then
myCell.EntireRow.Insert Shift:=xlDown
myCell.Offset(-1, 0).Value = myValue
indexCell.Resize(mergeRowCount + 1, 1).Merge
End If
End With
End Sub

Private Function magazineNo(magazineName As String, myDic As Object) As Long
Dim i As Long
Dim mykey As Variant

mykey = myDic.keys
For i = 0 To myDic.Count - 1
If mykey(i) = magazineName Then
magazineNo = i + 1
Exit Function
End If
Next i
End Function

Private Function categoryNo(categoryName As String, myDic As Object) As Long
Dim i As Long
Dim mykey As Variant

mykey = myDic.keys
For i = 0 To myDic.Count - 1
If mykey(i) = categoryName Then
categoryNo = i + 1
Exit Function
End If
Next i
End Function

お礼

ご回答ありがとうございました。
投稿いただいたマクロをそのまま使用したところ、解決することができました。ありがとうございます。
ただ、同じ「記事の概要」が複数表示されてしまうところがありましたが、それは手作業で消すことにしました。

お礼が大変遅くなりまして申し訳ありません。

回答No.3

tetumaru_1

Ａ２セル以下に入力関数
Ａ２　　　=CONCATENATE(雑誌名,カテゴリ，記事)
Ａ２答え　　FRIDAY芸能記事２

Ｂ１セル以下に貼付
Ｂ１　　　＜記事の概要＞
Ｂ２　　　記事２

Ｃ１セル以下に貼付
Ｃ１　　　＜雑誌名＞
Ｃ２　　　FRIDAY

Ｄ１セル以下に貼付
Ｄ１　　　政治
Ｄ２　　　=IF(CONCATENATE($C2,D$1,$B2)=$A2,$B2,"")
Ｄ２セルをコピーでＤ２：Ｆ○の範囲に貼り付ける。

お礼

ご回答ありがとうございました。
しかし、残念ながらこの方法では解決しませんでした。

お礼が大変遅くなりまして申し訳ありません。

補足

ご回答ありがとうございました。
しかし、残念ながらこの方法では解決しませんでした。

お礼が大変遅くなりまして申し訳ありません。

回答No.1

某HN クロメート(Chromate)（@CoalTar）

1.データの並べ替え
データ - 並べ替え
最優先されるキー 雑誌名 ●昇順
2番目に優先されるキー 記事カテゴリ ●昇順
とします

2. D1セル 「連結」
D2セル =A2&B2
下へオートフィル

3.E1セル 「作業列」
E2セル =IF(D1=D2,SUM(E1,1),1)
下へオートフィル

4. 名前をつける
A1:E9セル範囲 を選択して[Ctrl]+[F3] [レ]上端行

5. A11:A13
A11:A13まで雑誌名を重複なく抽出する
昇順であること

6. B11セル 個数の算出
=MAX(INDEX(作業列,MATCH(A11,雑誌名,0)):INDEX(作業列,MATCH(A11,雑誌名)))
下へオートフィル

7. A16セルに
=IF(B16=B15,SUM(A15,1),1)
下へオートフィル (B11:B13の合計行分)

8. B16セル =A2 または手入力

9. B17セル
=IF(A16>=LOOKUP(B16,$A$11:$B$13),INDEX(雑誌名,MATCH(B16,雑誌名)+1),B16)
フィルハンドル ダブルクリック

10. C15:E15セルまで記事カテゴリを入力(順番は何でもOK)

11. C16セル
=IF(ISERROR(INDEX(記事の概要,MATCH($B16&C$15,連結,0)-1+$A16)),
"",INDEX(記事の概要,MATCH($B16&C$15,連結,0)-1+$A16))
右へ 下へオートフィル

添付図参照 薄い緑は手入力
数式で行うようなことじゃない？？

お礼

ご丁寧なご回答ありがとうございました。
先に投稿いただいた方の方法で解決できましたしので、この方法は今回は使用しませんでした。

お礼が大変遅くなりまして申し訳ありません。