前回、Thunderbirdのデータ抽出をした話の続き。

 

エクスポートしたデータの中身は
下記のような内容がメール件数分続いていると思う。

Subject: 件名○○
From: 差出人○○ <xxx@xxx.co.jp>
Date: 2013/11/11 12:34
To: 宛先○○ <xxx@xxx.co.jp>
メール本文の内容

単純にこのテキストデータをエクセルに貼り付けて、
フィルタをかけるのが簡単な抽出の方法だと思う。

差出人を抽出するなら、「From: 」の値を含む行を絞り込めば良いし
日時を抽出するなら、「Date: 」の値を含む行を絞り込めば良い。

From:で絞り込んだ場合には、引用符（>）を含んだ行も表示されてしまうので
並べ替えで引用符つきの行を寄せて排除する必要があるかと思う。

 

で、余計な文字列の整形については、一括置換で処理ができる。

例えば、メールアドレスの抽出をする場合、
From: 差出人○○ <xxx@xxx.co.jp>
という文字列であれば、

ワイルドカード、アスタリスク（*）を使って、
「*<」を空白に一括置換する事で
xxx@xxx.co.jp>
になるので、後は後ろの「>」を空白に一括置換で消せば良い。

 

一部、下記のような形式も存在するが、
From: 差出人○○ [mailto:xxx@xxx.co.jp]
「*mailto:」を空白に置き換えれば良い。

 

10,000行ほどを一括置換すると、数十件おかしな部分もあるかと思うが、
手動で微調整するか、場合によっては無視しても良いかと考えている。
時間をかけてもせいぜい誤差の範囲なのであまり神経質にならないほうが良い。

 

で、ここからが本題のデータ集計に関して、
簡単にマクロを組んだ。

まず、集計するにあたり重複した値を排除して、
一意の値だけをピックアップする必要がある。

サンプルとしては下記のようなイメージだ。

 

このサンプルは20行なので目視で数えたらいいじゃんレベルだが、
今回実行するのは10,000行を超え、種類も300種類以上ある。

もっとも手軽にやろうとすれば、
フィルタの「重複するレコードは無視をする」を使えば出来るのだが、
マクロを組んで前後も含め自動化したいのである。

で、その一意の値を抽出するコードは下記。

 

Sub DataExtract()
    Dim myDic516 As Object, myKey516 As Variant
    Dim c516 As Variant, varData516 As Variant
        Set myDic516 = CreateObject("Scripting.Dictionary")
        With Worksheets("Sheet1")
            varData516 = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
        End With
        For Each c516 In varData516
            If Not c516 = Empty Then
                If Not myDic516.Exists(c516) Then
                    myDic516.Add c516, Null
                End If
            End If
        Next
        myKey516 = myDic516.Keys
        With Worksheets("Sheet2")
            .Range("A:A").ClearContents
            .Range("A1").Resize(myDic516.Count) = Application.WorksheetFunction.Transpose(myKey516)
        End With
        Set myDic516 = Nothing
End Sub

 

Sheet1のA列に入っているデータから一意の値を抽出してコピー、
Sheet2のA1に貼り付けるコードである。

実行後はこんな感じ。

 

Web上で見かけたページを参考にして作成したものなので
内容を理解しようと調べたが「連想配列」とかでよく分からなかったので
理解するのをあきらめた。まぁとりあえず動けばいいんですよ。

ここまでくればあとは簡単で、
関数COUNTIFで数を数えてもいいのだが、
せっかくなのでVBAだと下記のような感じ。

Sub DataExtract()
    Dim dc1516 As Integer, dc2516 As Integer
    Dim i1516 As Integer, cnt516 As Integer
    dc1516 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
    dc2516 = Worksheets("Sheet2").Range("A65536").End(xlUp).Row

    For i1516 = 1 To dc2516
    cnt516 = 0
    cnt516 = WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A1:A" & dc1516), Worksheets("Sheet2").Cells(i1516, 1))

    Worksheets("Sheet2").Cells(i1516, 2) = cnt516
    Next i1516
End Sub

 

実行するとこんな感じ。

 

あと数字の多い順で並び替えたければ下記を追加。

Sub DataExtract()
      Worksheets("Sheet2").Range("A1:B65536") _
              .Sort Key1:=Range("B1"), order1:=xlDescending
End Sub

 

 

 

以上でございます。

せっかくなので冒頭の一括置換もマクロを組もうかなと思うので
また追って投稿をする。（かも）