| |
こんにちは。かみちゃん です。
>質問事項1の年月日のスペースと曜日を抜いた出力がうまくいきませんでした。
>先に記載しました実際のメールデータの内容ですが、修正させていただきます。
>
>＜本文内容＞
>お名前：田中次郎
>年月日：23 年 11 月 17 日 水 曜日
>利用開始時刻：8：00
>利用終了時刻：9：00
>ご利用区分：現金
>交通手段：車
>ご利用場所：大阪難波店
>店員名：木村二郎
>店の雰囲気：3
>店のサービス：4
>状況1：これはテストです２。
>これもテストです２。
>状況2：あれはテストです２。
>あれもテストです２。
>その他ご意見：それはテストです２。
>それもテストです２。
>あいうえおかきくけこさしすせそたちつてと
>なにぬねのはひふへほ
>
>上記の内容で、
>
>利用開始時刻：8：00
>利用終了時刻：9：00
>ご利用区分：現金
>交通手段：車
>ご利用場所：大阪難波店
>
>の項目が増えていますが、これら5つの項目はエクセルには出力いたしません。
>
>この内容で修正していただいたプログラムを実行いたしましたら
>セルC2、C3、C4…に「ご利用場所」の内容が出力されてしまい、「年月日」の内容が出力されませんでした。
>
>また、
> Case "状況1"
> lngCellColumnNumber = 10
> Case "状況2"
> lngCellColumnNumber = 11
>
>の部分ですが、状況2の内容を状況1と同じセルに出力するにはどうしたらいいでしょうか？
>
> Case "状況1"
> lngCellColumnNumber = 10
> Case "状況2"
> lngCellColumnNumber = 10
>
>では、状況1に状況2が上書いてしまうので・・・
>
>あと、私が作ったプログラムではエクセルへのデータの継ぎ足しができません。
>次回違うメールデータを取り込んだ時には、前回取り込みエクセルに出力されたデータの次の行から新しく出力されるよう作りたいです。
>データがある最後の行を変数とすればいいのではないかと思いますが
年月日のスペースは、全角スペースなのでしょうか？
半角スペースでしょうか？
もしかしたら、Chr(160)のノーブレークスペース(NBSP)かもしれませんので、
それらにも対応ししてみました。
以下の◆と★の行が削除・修正・追加行です。
◆の行が、最終行を取得している部分です。
Option Explicit
Public Const adTypeText = 2
Public Const adReadLine = -2
Public Const adReadAll = -1
Public Const CONST_CHARSET = "iso-2022-jp"
Public Const CONST_MAIL_FOLDER_NAME = "eml"
Public Const DivideChar = "："
'Public Const HeaderLine = 1 '◆
Sub Sample3()
Dim ts As Object ''テキストストリーム
Dim lngTextLineNumber As Long, lngCellLineNumber As Long
Dim ファイルパス As String, TextContents As String, LineContents() As String
Dim DivideCharPosition As Long
Dim FSO As Object
Dim TextFile As Object
Dim File As Object
Dim FolderPosition As String
Dim strKoumoku As String, ss As String
Dim lngCellColumnNumber As Long
Dim HeaderLine As Long '◆
Set FSO = CreateObject("Scripting.FileSystemObject")
HeaderLine = Cells(Rows.Count, 1).End(xlUp).Row 'アクティブシートのA列の最終行 '◆
lngCellLineNumber = HeaderLine
FolderPosition = ThisWorkbook.Path & "\" & CONST_MAIL_FOLDER_NAME
For Each File In FSO.GetFolder(FolderPosition).Files
'ファイルをオープンする。（読み取り専用）
Set ts = CreateObject("ADODB.Stream")
'オブジェクトに保存するデータの種類を文字列型に指定する
ts.Type = adTypeText
'文字列型のオブジェクトの文字コードを指定する
ts.Charset = CONST_CHARSET
'オブジェクトのインスタンスを作成
ts.Open
'ファイルからデータを読み込む
ts.LoadFromFile (File.Path)
TextContents = ts.ReadText(adReadAll)
LineContents = Split(TextContents, vbCrLf)
lngCellLineNumber = lngCellLineNumber + 1
strKoumoku = "": ss = ""
For lngTextLineNumber = 0 To UBound(LineContents)
DivideCharPosition = InStr(LineContents(lngTextLineNumber), DivideChar)
'区切り文字が存在するか、項目名が取得できている場合処理する
If strKoumoku <> "" Or DivideCharPosition <> 0 Then
'区切り文字が存在する場合、項目名を取得する
If DivideCharPosition <> 0 Then
strKoumoku = Left(LineContents(lngTextLineNumber), DivideCharPosition - 1)
Select Case strKoumoku
Case "お名前"
lngCellColumnNumber = 1
Case "年月日"
lngCellColumnNumber = 3
Case "店員名"
lngCellColumnNumber = 5
Case "店の雰囲気"
lngCellColumnNumber = 6
Case "店のサービス"
lngCellColumnNumber = 8
Case "状況1"
lngCellColumnNumber = 10
Case "状況2"
lngCellColumnNumber = 10 '★
Case "その他ご意見"
lngCellColumnNumber = 12
Case Else
strKoumoku = ""
End Select
End If
'項目名が取得できている場合処理する
If strKoumoku <> "" Then
With Cells(lngCellLineNumber, lngCellColumnNumber)
If DivideCharPosition <> 0 Then
ss = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
If strKoumoku = "年月日" Then
ss = Replace(Replace(Replace(ss, " ", ""), " ", ""), Chr(160), "") '★
ss = Mid(ss, 1, InStr(ss, "日"))
End If
If strKoumoku = "状況2" Then '★
.Value = .Value & ss '★
Else '★
.Value = ss
End If '★
Else
.Value = .Value & LineContents(lngTextLineNumber)
End If
End With
End If
End If
Next lngTextLineNumber
ts.Close
Set ts = Nothing
Next File
Set FSO = Nothing
End Sub
|
|
かみちゃん
- 10/9/9(木) 16:27 -
