一連のtxtからexcelに表形式で取り込みたい

質問

メールをtxtデータにしたものをツールかマクロを使い下記のような表形式でexcelに取り込みたいです。
データの中身は勤務データです。

|件名 |送信者 |日付 ｜宛先 ｜本文
|山田 5/7|山田のアドレス |2013/5/8 8:03 ｜私のアドレス ｜9:00-18:00
|佐藤 5/7|佐藤のアドレス |2013/5/8 12:06｜私のアドレス ｜9:30-20:00
|田中 5/8|田中のアドレス|2013/5/9 16:04｜私のアドレス ｜9:00-12:00 午後休です。
（表示がずれていますが、お許しください）

メーラーはThunderbirdでImportExportToolsを使い、100件程度のメールを一つのtxtファイルにしています。

txtの中身は以下のように同じような内容が繰り返し縦に記述されています。
----------------------------------
Subject: 山田 5/7
From: 山田のアドレス
Date: 2013/5/8 8:03
To: 私のアドレス
9:00-18:00

Subject: 佐藤 5/7
From: 佐藤のアドレス
Date: 2013/5/8 12:06
To: 私のアドレス
9:30-20:00

…（以下省略）
----------------------------------

excelの標準取り込み機能ではすべて縦に転記されてしまい使い物になりません…

本文は2行以上（改行含む）の時もありますが、できれば一つのセルに収まるようにしたいです。
セルの中で改行されている分には構いません。

今まで手作業で勤務データを移していましたが、ミスがあるうえにそれだけで1日が終わってしまいます…

これを可能にする方法を教えていただけないでしょうか？
ツールでもマクロでも構いません。よろしくお願いします。

回答No.3

K Kazz（@JazzCorp） · ベストアンサー

＜＜修正版＞＞
'指定されたtxtファイルを読み、メール1件の先頭レコードのキー毎に、その間のレコードを１行のセルに展開する（縦から横へ位置変換してるだけ）
'最初の"Subject: "が現れるまでのレコードはゴミ扱い（捨てる）
'元ネタは、マクロブックと同じフォルダに入れる
'結果は、アクティブシートに出る
'Constのところは環境に合わせて設定する必要がある
Option Explicit
Sub MailText2Sheet()
Const xName = "隣の山田君.txt" 'ネタファイル
Const xHead = "Subject: " 'メール1件の先頭レコードのキー
Const xLabel = "件名｜送信者｜日付｜宛先｜本文"
Dim xFF01 As Integer
Dim xPath As String
Dim xFileName As String
Dim xExtent As String
Dim xREC As Variant
Dim xRange As Range
Dim xRag As Boolean
Dim kk As Long
Dim nn As Long
xPath = ThisWorkbook.Path & "\"
xFileName = Dir(xPath & xName, vbNormal)
If (xFileName <> Empty) Then
With ThisWorkbook.ActiveSheet
.UsedRange.ClearContents
Cells(1, "A").Resize(, 5).Value = Split(xLabel, "｜")
With Cells(1, "A").Resize(, 5)
.Font.Bold = True
.Interior.ColorIndex = 36
End With
nn = 1
xRag = True
xFF01 = FreeFile()
Open xFileName For Input As #xFF01
Do Until EOF(xFF01)
Line Input #xFF01, xREC
If (InStr(xREC, xHead)) Then
nn = nn + 1
kk = 0
xRag = False
Else
End If
If Not (xRag) Then
kk = kk + 1
Cells(nn, kk).Value = xREC
End If
Loop
Close
'キーワードを消す
For Each xRange In .UsedRange
xRange.Value = Replace(xRange.Value, xHead, "")
Next
.Columns("A:E").AutoFit
End With
Else
MsgBox (xPath & xName & "：File not Found !!")
End If
End Sub

お礼

ご回答ありがとうございます。
修正版の再コメントも頂きありがとうございます。

無事に要件を満たした表を作ることができました！
一日中勤務データとにらめっこすることがなくなると思うと
非常に気が楽です。

助けて頂き本当にありがとうございました。

回答No.2

K Kazz（@JazzCorp）

'Constのところは環境に合わせて設定する必要がある
Option Explicit
Sub MailText2Sheet()
Const xName = "隣の山田.txt"
Const xHead = "Subject: "
Const xHeads = 1
Const xLabel = "件名｜送信者｜日付｜宛先｜本文"
Dim FSO As Object
Dim xFF01 As Integer
Dim xPath As String
Dim xFileName As Variant
Dim xExtent As String
Dim xREC As Variant
Dim xRag As Boolean
Dim kk As Long
Dim nn As Long
Application.ScreenUpdating = False
xPath = ThisWorkbook.Path & "\"
xFileName = Dir(xPath & xName, vbNormal)
If (xFileName <> Empty) Then
With ThisWorkbook.Worksheets(1)
.UsedRange.ClearContents
Cells(1, "A").Resize(, 5).Value = Split(xLabel, "｜")
With Cells(1, "A").Resize(, 5)
.Font.Bold = True
.Interior.ColorIndex = 36
End With
nn = xHeads
xRag = True
Set FSO = CreateObject("Scripting.FileSystemObject")
xFF01 = FreeFile()
Open xFileName For Input As #xFF01
Do Until EOF(xFF01)
Line Input #xFF01, xREC
If (InStr(xREC, xHead)) Then
nn = nn + 1
kk = 0
xRag = False
Else
End If
If Not (xRag) Then
kk = kk + 1
Cells(nn, kk).Value = xREC
End If
Loop
Close
Set FSO = Nothing
End With
Else
MsgBox ("Open Error：" & xPath & xName), vbInformation
End If
Columns("A:E").AutoFit
Application.ScreenUpdating = True
End Sub

回答No.1

misatoanna

テキストファイルは、１行目から「データ行５、空白行１」で連続している前提です。
また、取り込み先Excelの１行目(タイトル)は手入力していただくとしまして――

次のマクロを試してみてください。
※５行目の " " 内は、テキストファイルの実際のフルパスに書き換えます。

Sub Test()
　Dim FName As String, FF As Variant, Bun As String
　Dim gyo As Long, rw As Long
　Application.ScreenUpdating = False
　FName = "C:\aaaa\bbbb\nnnn.txt"　　'※
　gyo = 1　　'TEXTファイルの行
　FF = FreeFile
　rw = 2　　　'Excelの行カウンタ
　Open FName For Input As #FF
　Do Until EOF(FF)
　　Line Input #FF, Bun
　　Select Case gyo Mod (6)
　　　Case Is = 1
　　　　Cells(rw, 1).Value = Replace(Bun, "Subject:", "")
　　　Case Is = 2
　　　　Cells(rw, 2).Value = Replace(Bun, "From:", "")
　　　Case Is = 3
　　　　Cells(rw, 3).Value = Replace(Bun, "Date:", "")
　　　Case Is = 4
　　　　Cells(rw, 4).Value = Replace(Bun, "To:", "")
　　　Case Is = 5
　　　　Cells(rw, 5).Value = Bun
　　　Case Is = 0
　　　　rw = rw + 1
　　End Select
　　gyo = gyo + 1
　Loop
　Close #FF
　Application.ScreenUpdating = True
End Sub

お礼

ご回答ありがとうございます。

txtファイル内が定型ならうまくいくのですが、
勤務の報告を2行にわたって書いてくる人もいたりするので、
そうするとずれてしまいますね。

ちょっといじればできそうな気もしますが、
マクロ初心者の私には少し難しそうでした。
でも回答頂きありがとうございました。