Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2689 / 13645 ツリー ←次へ | 前へ→

【66547】【VBA】メールデータをエクセルに出力するプログラムの修正の依頼 poosuke 10/9/9(木) 11:47 質問[未読]
【66548】Re:【VBA】メールデータをエクセルに出力す... かみちゃん 10/9/9(木) 13:00 発言[未読]
【66549】Re:【VBA】メールデータをエクセルに出力す... かみちゃん 10/9/9(木) 13:12 発言[未読]
【66551】Re:【VBA】メールデータをエクセルに出力す... poosuke 10/9/9(木) 15:31 質問[未読]
【66552】Re:【VBA】メールデータをエクセルに出力す... かみちゃん 10/9/9(木) 16:27 発言[未読]
【66556】Re:【VBA】メールデータをエクセルに出力す... poosuke 10/9/10(金) 9:08 お礼[未読]

【66547】【VBA】メールデータをエクセルに出力す...
質問  poosuke  - 10/9/9(木) 11:47 -

引用なし
パスワード
   題名についてご質問させていただきます。具体的な質問事項は最後に記載しております。
複数のアンケートのようなメールデータを取り込み、項目ごとに「:」以下の内容をエクセルに出力するプログラムをVBAで作りました。
「:」より前の項目はヘッダーとしてあらかじめエクセルに記入しておきます。
取り込むメールデータは「eml」というフォルダにドラッグ&ドロップで保存しておきます。

実際のメールデータの本文内容は下記となります。

お名前:田中次郎
年月日:23 年 11 月 17 日 水 曜日
店員名:木村二郎
店の雰囲気:3
店のサービス:4
状況1:これはテストです2。
これもテストです2。
状況2:あれはテストです2。
あれもテストです2。
その他ご意見:それはテストです2。
それもテストです2。
あいうえおかきくけこさしすせそたちつてと
なにぬねのはひふへほ


<プログラム>
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 Sample()

  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
         
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  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
    
    For lngTextLineNumber = 0 To UBound(LineContents)
      DivideCharPosition = InStr(LineContents(lngTextLineNumber), DivideChar)
      
      If DivideCharPosition <> 0 Then
      
        Select Case Left(LineContents(lngTextLineNumber), DivideCharPosition - 1)
        
        Case "お名前"
        Cells(lngCellLineNumber, 1).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "年月日"
        Cells(lngCellLineNumber, 3).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "店員名"
        Cells(lngCellLineNumber, 5).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "店の雰囲気"
        Cells(lngCellLineNumber, 6).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "店のサービス"
        Cells(lngCellLineNumber, 8).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "状況1"
        Cells(lngCellLineNumber, 10).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "状況2"
        Cells(lngCellLineNumber, 11).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        Case "その他ご意見"
        Cells(lngCellLineNumber, 12).Value = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
        End Select
      
      End If
      
    Next lngTextLineNumber
    
    ts.Close
    Set ts = Nothing
  
  Next File
  
  Set FSO = Nothing

End Sub


<質問事項>
1.年月日を出力する際、スペースが入った「23 年 11 月 17 日 水 曜日」ではなく、スペースと曜日を抜いた「23年11月17日」と出力させたい。

2.状況1、状況2やその他意見の項目で、本文内容に改行が入った場合、改行以下の内容が出力されないのを改行を無視して一行で出力するようにしたい。

3.状況1と状況2の内容を今は別々のセルに出力するが、それを一つのセルにまとめて出力するようにしたい。

これらを実現するには、どうプログラムを修正すればよろしいでしょうか?
具体的にプログラムを書きなおしていただけると有り難いです。

説明が長々となりややこしいと思いますが、ご助力の方お願いいたします。

【66548】Re:【VBA】メールデータをエクセルに出力...
発言  かみちゃん E-MAIL  - 10/9/9(木) 13:00 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>これらを実現するには、どうプログラムを修正すればよろしいでしょうか?
>具体的にプログラムを書きなおしていただけると有り難いです。

提示されたコードをできるだけ活かして書きなおすと以下のような感じでできると思います。

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 Sample1()

  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 ss1 As String, ss2 As String, ss3 As String
  Dim lngCellColumnNumber As Long
     
  Set FSO = CreateObject("Scripting.FileSystemObject")
 
  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
  
    ss1 = "": ss2 = "": ss3 = ""
    For lngTextLineNumber = 0 To UBound(LineContents)
      DivideCharPosition = InStr(LineContents(lngTextLineNumber), DivideChar)
      If ss2 <> "" Or DivideCharPosition <> 0 Then
        If DivideCharPosition <> 0 Then
         ss1 = Left(LineContents(lngTextLineNumber), DivideCharPosition - 1)
         Select Case ss1
          Case "お名前", "年月日", "店員名", "店の雰囲気", "店のサービス", "状況1", "状況2", "その他ご意見"
           ss2 = ss1
         End Select
        Select Case ss2
         Case "お名前"
          lngCellColumnNumber = 1
         Case "年月日"
          lngCellColumnNumber = 3
         Case "店員名"
          lngCellColumnNumber = 5
         Case "店の雰囲気"
          lngCellColumnNumber = 6
         Case "店のサービス"
          lngCellColumnNumber = 8
         Case "状況1"
          lngCellColumnNumber = 10
         Case "状況2"
          lngCellColumnNumber = 11
         Case "その他ご意見"
          lngCellColumnNumber = 12
        End Select
        End If
        If ss2 <> "" Then
         With Cells(lngCellLineNumber, lngCellColumnNumber)
          ss3 = Mid(LineContents(lngTextLineNumber), DivideCharPosition + 1)
          If ss2 = "年月日" Then
           ss3 = Replace(ss3, " ", "")
           ss3 = Mid(ss3, 1, InStr(ss3, "日"))
          Else
           ss3 = .Value & ss3
          End If
          .Value = ss3
         End With
        End If
   
      End If
   
    Next lngTextLineNumber
  
    ts.Close
    Set ts = Nothing
 
  Next File
 
  Set FSO = Nothing

End Sub

【66549】Re:【VBA】メールデータをエクセルに出力...
発言  かみちゃん E-MAIL  - 10/9/9(木) 13:12 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>これらを実現するには、どうプログラムを修正すればよろしいでしょうか?
>>具体的にプログラムを書きなおしていただけると有り難いです。
>
>提示されたコードをできるだけ活かして書きなおすと以下のような感じでできると思います。

少し見直しました。こちらのほうがいいかと思います。

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 Sample2()

  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
     
  Set FSO = CreateObject("Scripting.FileSystemObject")
 
  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 = 11
          Case "その他ご意見"
           lngCellColumnNumber = 12
         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(ss, " ", "")
            ss = Mid(ss, 1, InStr(ss, "日"))
           End If
           .Value = ss
          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

【66551】Re:【VBA】メールデータをエクセルに出力...
質問  poosuke  - 10/9/9(木) 15:31 -

引用なし
パスワード
   早速のご回答誠にありがとうございます、かみちゃん様。

実際にプログラムを実行させましたら、質問事項2はうまく実行することができました。

質問事項1の年月日のスペースと曜日を抜いた出力がうまくいきませんでした。
先に記載しました実際のメールデータの内容ですが、修正させていただきます。

<本文内容>
お名前:田中次郎
年月日:23 年 11 月 17 日 水 曜日
利用開始時刻:8:00
利用終了時刻:9:00
ご利用区分:現金
交通手段:車
ご利用場所:大阪難波店
店員名:木村二郎
店の雰囲気:3
店のサービス:4
状況1:これはテストです2。
これもテストです2。
状況2:あれはテストです2。
あれもテストです2。
その他ご意見:それはテストです2。
それもテストです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が上書いてしまうので・・・

あと、私が作ったプログラムではエクセルへのデータの継ぎ足しができません。
次回違うメールデータを取り込んだ時には、前回取り込みエクセルに出力されたデータの次の行から新しく出力されるよう作りたいです。
データがある最後の行を変数とすればいいのではないかと思いますが、そこまでのスキルがないために
プログラムを書けずにおります。
ご教授の程よろしくお願いいたします。

質問ばかりになり厚かましいとは思いますが、ご修正をお願いいたします。


▼かみちゃん さん:
>こんにちは。かみちゃん です。
>
>>>これらを実現するには、どうプログラムを修正すればよろしいでしょうか?
>>>具体的にプログラムを書きなおしていただけると有り難いです。
>>
>>提示されたコードをできるだけ活かして書きなおすと以下のような感じでできると思います。
>
>少し見直しました。こちらのほうがいいかと思います。
>
>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 Sample2()
>
>  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
>     
>  Set FSO = CreateObject("Scripting.FileSystemObject")
> 
>  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 = 11
>          Case "その他ご意見"
>           lngCellColumnNumber = 12
>         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(ss, " ", "")
>            ss = Mid(ss, 1, InStr(ss, "日"))
>           End If
>           .Value = ss
>          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

【66552】Re:【VBA】メールデータをエクセルに出力...
発言  かみちゃん E-MAIL  - 10/9/9(木) 16:27 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>質問事項1の年月日のスペースと曜日を抜いた出力がうまくいきませんでした。
>先に記載しました実際のメールデータの内容ですが、修正させていただきます。
>
><本文内容>
>お名前:田中次郎
>年月日:23 年 11 月 17 日 水 曜日
>利用開始時刻:8:00
>利用終了時刻:9:00
>ご利用区分:現金
>交通手段:車
>ご利用場所:大阪難波店
>店員名:木村二郎
>店の雰囲気:3
>店のサービス:4
>状況1:これはテストです2。
>これもテストです2。
>状況2:あれはテストです2。
>あれもテストです2。
>その他ご意見:それはテストです2。
>それもテストです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

【66556】Re:【VBA】メールデータをエクセルに出力...
お礼  poosuke  - 10/9/10(金) 9:08 -

引用なし
パスワード
   おはようございます、かみちゃん様。

ご修正していただいたプログラムを実行いたしましたところ
質問事項の項目全てがうまく動きました。

この度は多大なご協力誠にありがとうございました。
プログラムの説明もご丁寧でとても分かりやすかったです。

2689 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free