Excel VBA質問箱 IV

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

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


3118 / 13644 ツリー ←次へ | 前へ→

【64094】セル内の特定(不定形)文字列の削除 GONTA 10/1/18(月) 14:54 質問[未読]
【64098】Re:セル内の特定(不定形)文字列の削除 Hirofumi 10/1/18(月) 19:43 回答[未読]
【64099】Re:セル内の特定(不定形)文字列の削除 かみちゃん 10/1/18(月) 20:38 発言[未読]
【64133】Re:セル内の特定(不定形)文字列の削除 GONTA 10/1/21(木) 12:55 お礼[未読]

【64094】セル内の特定(不定形)文字列の削除
質問  GONTA  - 10/1/18(月) 14:54 -

引用なし
パスワード
   すみません
再度の質問です。

先日のかみちゃんさんのお陰で特定の文字列の転記に光が
見えてきたのですが、また、題名の問題にぶつかりました。
お助け下さい。

内容
一つのセル内に以下のようなメールの内容をCSVで取り込んだ
のですが、下の部分を削除したいのです。



  A
  商品の注文
  キャンペーンの説明・・・・・・・
  ・・(行数不定の不定長文字列)・・・・・・
1 ・・・・・・・・・・・・・・・・
  −−−−−−−−−−−−−−−−−−−−−−
  注文フォーム
  −−−−−−−−−−−−−−−−−−−−−−
  ・・・・・・・・・・・・
  ・・・・・・・・・・・・

  −−−−−−−−−−−−−−−−−−−−−−
  □商品名:○○○
  □数量 :○○個
  □お名前:○○○○
  □電話 :○○○○○○○○○○○
  □住所 :○○○○○○○○○○
  お客様コメント
      :○○○○○○○○○○○○

  −−−−−−−−−−−−−−−−−−−−−−

  社内連絡様コメントetc
  ・・・・・・・・・・・・・・・・・・
  ・・・・・・・(行数不定の不定長文字列)
  ・・・・・・・・・・・・・・・・・・・

(例文終わり)
  
  と言うのがありますが、この一番下の−−−−
  以下の文字列を削除する方法をお教え頂けませんで
  しょうか。

  本当に初心者的な質問ですみません。

【64098】Re:セル内の特定(不定形)文字列の削除
回答  Hirofumi  - 10/1/18(月) 19:43 -

引用なし
パスワード
   データを見ていないので、上手く行かないかも?
前の質問と同じに、シートに項目別に出力すると言う事で??

Option Explicit

Public Sub Sample_2()

'  シートに読み込まれた文字列から抽出する場合

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim lngTop As Long
  Dim lngLf As Long
  Dim lngColon As Long
  Dim strProm As String

  'Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = ActiveSheet.Range("A1")

  '結果出力の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngResult = ActiveSheet.Range("B1")

  '抽出する項目名を列挙
  vntKeys = Array("□商品名", "□数量", "□お名前", "□電話", "□住所", "お客様コメント")
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '項目名分の要素数を持つ出力用配列を確保
  ReDim vntResult(UBound(vntKeys))
  
  'Key列に就いて繰り返し
  For i = 1 To lngRows
    '1セル分変数に取得
    vntData = rngList.Cells(i, 1).Value
    '項目名分繰り返し
    For j = 0 To UBound(vntKeys)
      '項目名の位置を取得
      lngTop = InStr(1, vntData, vntKeys(j), vbBinaryCompare)
      '項目名が在った場合
      If lngTop > 0 Then
        '項目名の後ろに在るコロンの位置を取得
        lngColon = InStr(lngTop + 1, vntData, ":", vbTextCompare)
        'コロンが在ったら
        If lngColon > 0 Then
          'コロンの後ろのLf(ラインフィード)の位置を取得
          lngLf = InStr(lngColon + 1, vntData, vbLf, vbBinaryCompare)
          '見つかった、コロンとLfの間の文字列を取得し配列指定位置に格納
          vntResult(j) = Mid(vntData, lngColon + 1, lngLf - lngColon - 1)
        End If
      End If
    Next j
    '結果を出力
    rngResult.Cells(i, 1).Resize(, UBound(vntKeys) + 1).Value = vntResult
    '出力用配列を初期化(再確保)
    ReDim vntResult(UBound(vntKeys))
  Next i
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Public Sub Sample_3()

'  Csvファイ理から直接抽出する場合

  Dim i As Long
  Dim lngRows As Long
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim lngTop As Long
  Dim lngLf As Long
  Dim lngColon As Long
  Dim dfn As Integer
  Dim vntFilename As Variant
  Dim lngWrite As Long
  Dim strBuff As String
  Dim strProm As String

  '結果出力の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngResult = ActiveSheet.Range("B1")

  '抽出する項目名を列挙
  vntKeys = Array("□商品名", "□数量", "□お名前", "□電話", "□住所", "お客様コメント")
  
  If Not GetReadFile(vntFilename, ThisWorkbook.Path) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      lngRows = 0
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '項目名分の要素数を持つ出力用配列を確保
  ReDim vntResult(UBound(vntKeys))
  
  'ファイルをOpen
  dfn = FreeFile
  Open vntFilename For Input As dfn
  
  Do Until EOF(dfn)
    'ファイルから1行分取得
    Line Input #dfn, strBuff
    If strBuff <> "" Then
      '項目名分繰り返し
      For i = 0 To UBound(vntKeys)
        '項目名の位置を取得
        lngTop = InStr(1, strBuff, vntKeys(i), vbBinaryCompare)
        '項目名が在った場合
        If lngTop > 0 Then
          '項目名の後ろに在るコロンの位置を取得
          lngColon = InStr(lngTop + 1, strBuff, ":", vbTextCompare)
          'コロンが在ったら
          If lngColon > 0 Then
            'コロンの後ろのLf(ラインフィード)の位置を取得
            lngLf = InStr(lngColon + 1, strBuff, vbLf, vbBinaryCompare)
            '見つかった、コロンとLfの間の文字列を取得し配列指定位置に格納
            vntResult(i) = Mid(strBuff, lngColon + 1, lngLf - lngColon - 1)
          End If
        End If
      Next i
      '結果を出力
      lngWrite = lngWrite + 1
      rngResult.Cells(lngWrite, 1).Resize(, UBound(vntKeys) + 1).Value = vntResult
      '出力用配列を初期化(再確保)
      ReDim vntResult(UBound(vntKeys))
    End If
  Loop
  
  Close #dfn
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【64099】Re:セル内の特定(不定形)文字列の削除
発言  かみちゃん E-MAIL  - 10/1/18(月) 20:38 -

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

>特定の文字列の転記に光が見えてきた

【64083】の質問に関連していると思いますが、

>この一番下の−−−−以下の文字列を削除する方法

前回提示したコードを修正することだけでできます。
以下に全体を示しますが、修正箇所は★の部分です。

Sub Sample1()
 Dim rngData As Range
 Dim lngRows As Long
 Dim vntData As Variant
 Dim lngRow As Long
 Dim ss As String
 Dim lngPos As String
 Dim v As Variant
 Dim i As Long
  
 'Listの左上隅セル位置を基準として設定
 With ActiveSheet.Cells(1, "A")
  '転記結果が6列の場合、1加算して7とする(元データ分を含める)
  Set rngData = .Resize(.Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1, 7)
  'データを配列に取得(作業列(お客様コメント用)を含む)
  vntData = rngData.Resize(, rngData.Columns.Count + 1).Value
 End With
 
 For lngRow = 1 To UBound(vntData, 1)
  ss = vntData(lngRow, 1)
  lngPos = InStrRev(ss, vbLf & "−−−−−−−−−−−−−−−−−−−−−−") '★
  If lngPos > 1 Then '★
   ss = Mid(ss, 1, lngPos - 1) '★
   lngPos = InStr(ss, "□商品名:")
   If lngPos > 0 Then
    v = Split(Mid(ss, lngPos), vbLf)
    If UBound(v) = 6 Then
     For i = 0 To UBound(v)
      lngPos = InStr(v(i), ":")
      If lngPos > 0 Then
       vntData(lngRow, i + 2) = Mid(v(i), lngPos + 1)
      End If
     Next
     vntData(lngRow, 7) = vntData(lngRow, 8)
    Else
     vntData(lngRow, 2) = "項目数が一致しません" & UBound(v)
    End If
   Else
    vntData(lngRow, 2) = "内容に""□商品名:""がありません"
   End If
  Else '★
    vntData(lngRow, 2) = "内容に""−−−−−−−−−−−−−−−−−−−−−−""がありません" '★
  End If '★
 Next
 rngData.Value = vntData

 MsgBox "処理を終了しました"
End Sub

【64133】Re:セル内の特定(不定形)文字列の削除
お礼  GONTA  - 10/1/21(木) 12:55 -

引用なし
パスワード
   かみちゃん さん
GONTAです。

ありがとうございました。
全て解決しました。

お陰様で半日かかる仕事が2分ですみました。

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