しょぼPRG

iPodのライブラリをExcelに取り込むプログラムを勝手に作ってみた。去年大学で少し勉強したExcelのVBAがこんなところで役に立つとは。
ライブラリのxmlファイルを一旦メモ帳で開き、それをExcelのワークシート上にコピペしておく必要があるのだが。


そのあと曲名・アーティスト名・アルバム名・曲番・再生回数・最終再生日時を取り出して別のワークシートにコピーし、いらないタグを消去。最後に並べ替えとフォントを小さくして終了。

半角記号が入ってるとその部分だけこのようになる場合があるが、

そこまで手が回らないので放置...

VBAのソースはこちら(クレーム等は一切受け付けませんので念のため。っていうか、作った本人も使い方が分からない関数とかあるので、対処不可だったりする)
参考に：http://members.ld.infoseek.co.jp/makotowatana/vba4.html#search

Sub ライブラリ変換()
'事前準備として、まずxmlファイルをメモ帳など(テキストファイルエディタ)で開き全部コピーし、Sheet1上にコピーする
'出力先はSheet2

Dim セル As Range
Dim x As Integer
x = 1
Worksheets("Sheet1").Activate 'xml元データのある場所

If Sheet1.Cells(1, 1) = "" Then MsgBox "データが入っていません。作業を中止します"
If Sheet1.Cells(1, 1) = "" Then Exit Sub

For Each セル In [A1:D30000] '捜索範囲 下の不要文字消去も調整すること
If セル.Value Like "*Name*" Then
x = x + 1
'コピー先の改行処理
End If
If セル.Value Like "*Name*" Then
Sheet2.Cells(x, 1) = セル.Value
'曲名コピー
End If
If セル.Value Like "*Artist*" Then
Sheet2.Cells(x, 2) = セル.Value
'アーティスト名コピー
End If
If セル.Value Like "*Album*" Then
Sheet2.Cells(x, 3) = セル.Value
'アルバム名コピー
End If
If セル.Value Like "*Track Number*" Then
Sheet2.Cells(x, 4) = セル.Value
'曲番コピー
End If
If セル.Value Like "*Play Count*" Then
Sheet2.Cells(x, 5) = セル.Value
'再生回数コピー
End If
If セル.Value Like "*Play Date UTC*" Then
Sheet2.Cells(x, 6) = セル.Value
'再生日時コピー
End If
Next
Range("A1").Activate

'↑データのコピーのみ

'↓不要文字消去作業
Worksheets("Sheet2").Activate
Sheet2.Cells(1, 1) = "曲名"
Sheet2.Cells(1, 2) = "アーティスト"
Sheet2.Cells(1, 3) = "アルバム"
Sheet2.Cells(1, 4) = "曲番"
Sheet2.Cells(1, 5) = "再生回数"
Sheet2.Cells(1, 6) = "最終再生日時"

'I以降は収録曲数以上にしておくこと
For Each セル In [A1:I9999]
If セル.Value Like "*Name*" Then
セル.Replace What:="Name", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'曲名
End If
If セル.Value Like "*Artist*" Then
セル.Replace What:="Artist", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'アーティスト名
End If
If セル.Value Like "*Album*" Then
セル.Replace What:="Album", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'アルバム名
End If
If セル.Value Like "*Track Number*" Then
セル.Replace What:="Track Number", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'トラック番号
End If
If セル.Value Like "*Play Count*" Then
セル.Replace What:="Play Count", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'再生回数
End If
If セル.Value Like "*Play Date UTC*" Then
セル.Replace What:="Play Date UTC", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
'再生日時
End If
If セル.Value Like "**" Then
セル.Replace What:="", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
If セル.Value Like "**" Then
セル.Replace What:="", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
If セル.Value Like "**" Then
セル.Replace What:="", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
If セル.Value Like "**" Then
セル.Replace What:="", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
If セル.Value Like "**" Then
セル.Replace What:="", Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
Next
Range("A1").Activate

' フォントと列幅の修正
Worksheets("Sheet2").Activate

Cells.Select
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A1").Select
Columns("A:A").ColumnWidth = 15.63
Columns("C:C").ColumnWidth = 15.63
Columns("D:D").ColumnWidth = 3.5
Columns("E:E").ColumnWidth = 6.13
Columns("F:F").ColumnWidth = 16.25

' 並べ替え作業(アーティスト - アルバム - 曲番)

Cells.Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal, DataOption3:=xlSortNormal

End Sub

そもそもコレを作ったのは、iPodの再生回数を月毎に集計しやすくするようにするのが目的。んで今月よく聴いた曲を集計しやすくしようとするわけで