Excel VBA質問箱 IV

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

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


18078 / 76732 ←次へ | 前へ→

【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
2 hits

【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 お礼

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