Excel VBA質問箱 IV

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

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


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

【7123】テキストファイルからのデータ取得について アート 03/8/23(土) 12:03 質問
【7131】Re:テキストファイルからのデータ取得につい... INA 03/8/23(土) 14:02 回答
【7140】Re:テキストファイルからのデータ取得につい... Hirofumi 03/8/23(土) 22:43 回答
【7156】Re:テキストファイルからのデータ取得につ... アート 03/8/24(日) 13:28 お礼

【7123】テキストファイルからのデータ取得について
質問  アート  - 03/8/23(土) 12:03 -

引用なし
パスワード
   お世話になります。
VBA初心者です。よろしくお願いします。
さて、現在以下のようなテキストファイルがあります。
そのテキストファイルの中のデータをエクセルに読み込み
必要な箇所のデータを抜き取り新しいファイルに整理したい
のですが、ご教授願います。
対象テキストファイル数は、以下のファイル名が対象となります。
ファイルは、デスクトップのtestというフォルダ内にあります。

(テキストファイル名)
22030808_160    22(機番)03(03年)08(08月)08(08日)_160(160番目)
対象データは、22機番の03年08月07日から08日の001番目からのデータすべて
001番目から999番目までのデータファイルとなります。

(テキストファイル内容)
右位置1  = , 5.1 , 224.1 , 51
右位置2  = , 10.9 , 232.1 , 109
左位置1  = , 5.1 , 224.1 , 51
左位置2  = , 10.9 , 232.1 , 109
右P1 = , 34.7 , 58.8 , 347
右P2 = , 164.9 , 79.4 , 1649
左P1 = , 25.3 , 57.6 , 253
左P2 = , 154.5 , 78.4 , 1545

    ↑数値は、右よりX,Y,データポイント数となってます。

これらを以下のようにエクセルファイルに整理したい

  A    B     C    D     E     F     G     H    I
1 ファイル名 右P1(X) 右P1(Y) 右P2(X) 右P2(Y) 左P1(X) 左P1(Y) 左P2(X) 左P2(Y)
2 22030808_001 * * * *      *  *     *  *     
3   ・
4   ・
5 22030808_160 34.7 58.8 164.9 79.4 25.3 57.6 154.5 78.4

以上よろしくご教授願います。

【7131】Re:テキストファイルからのデータ取得につ...
回答  INA  - 03/8/23(土) 14:02 -

引用なし
パスワード
   よく分かってないですが、
マクロの自動記録は試しましたか?
自動記録して修正すれば、ほとんど出来そうな気もしますが・・

【7140】Re:テキストファイルからのデータ取得につ...
回答  Hirofumi E-MAIL  - 03/8/23(土) 22:43 -

引用なし
パスワード
   上手く纏まらないけどこんな物かな?
幾つか条件が有ります
1、(テキストファイル内容)で
 この8行のうち、下4行は必ずこの順番で有る事
2、ファイル名の形式は、22030808_160の形式で有る事
 拡張子は、「Function GetDataFile」の
 「Const strExtend As String = ".txt"」で指定して下さい
簡単に行くかと思ったら意外と面倒、とくにファイルの指定が?
上手く行かなかったらゴメン
Excel97でも動く様にして有りますが、Excel2000以上なら、
Split97の部分をSplit関数に直して下さい
また、Function GetNameもInstrの逆関数が有るので、
其方に直すとコードが簡単に成ると思います

Option Explicit

Public Sub MakeDataSheet()

  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim dfn As Integer
  Dim strFileName() As String
  Dim strBuff As String
  Dim vntResult(0 To 8) As Variant
  Dim vntData As Variant
  Dim vntItems As Variant
  Dim lngWriteRow As Long
  
  'データファイルが無いなら
  If Not GetDataFile(strFileName()) Then
    Exit Sub
  End If
  
  '結果用の列見出しを作成
  For i = 0 To 8
    vntResult(i) = Choose(i + 1, "ファイル名", "右P1(X)", "右P1(Y)", _
                  "右P2(X)", "右P2(Y)", "左P1(X)", _
                  "左P1(Y)", "左P2(X)", "左P2(Y)")
  Next i
  'ファイルから読み込む行を特定する文字列を設定
  vntItems = Array("右P1", "右P2", "左P1", "左P2")
  
  '書き出し行を初期化
  lngWriteRow = 1
  'Sheet1に書き出す
  With Worksheets("Sheet1")
    '結果用の列見出しを出力
    .Cells(lngWriteRow, 1).Resize(, 9).Value = vntResult
    '書き出し行を更新
    lngWriteRow = lngWriteRow + 1
    'フォルダ上の指定ファイルを繰り返す
    For i = 0 To UBound(strFileName, 1)
      'ファイルバファ番号を取得
      dfn = FreeFile
      'ファイルをInputモードでOpen
      Open strFileName(i) For Input As dfn
      '結果用配列にファイル名を設定
      vntResult(0) = GetName(strFileName(i))
      'ファイルの終りまで繰り返し
      Do Until EOF(dfn)
        'ファイルより1行読み込み
        Line Input #dfn, strBuff
        For j = 0 To 3
          '先頭に"右P1", "右P2", "左P1", "左P2"が有る場合
          If InStr(1, strBuff, vntItems(j), _
                    vbBinaryCompare) = 1 Then
            '1行をカンマで切り出す
            vntData = Split97(strBuff, ",")
            'Excel2000以上なら以下の様に変更
'            vntData = Split(strBuff, ",")
            '2、3番目を結果配列に代入
            For k = 1 To 2
              vntResult(j * 2 + k) = Trim(vntData(k))
            Next k
            '"左P2"を読み込んだ時
            If j = 3 Then
              '結果を出力
              .Cells(lngWriteRow, _
                  1).Resize(, 9).Value = vntResult
              '書き出し行を更新
              lngWriteRow = lngWriteRow + 1
            End If
          End If
        Next j
      Loop
      'ファイルを閉じる
      Close #dfn
    Next i
  End With
  
End Sub

Private Function GetDataFile(strData() As String) As Boolean

  Dim i As Long
  Dim j As Long
  Dim strFilePath As String
  Dim strFileName As String
  Dim lngTop As Long
  Dim lngEnd As Long
  Dim lngStep As Long
  Dim strProm As String
  Dim lngScope(1) As Long
  Const strExtend As String = ".txt"
  
  '読み込むファイルの有るフォルダを指定
  strFilePath = "C:\Windows\デスクトップ\Test"
  strFilePath = InputBox("データの有るパスを指定して下さい", _
                          , strFilePath)
  If strFilePath = "" Then
    Exit Function
  End If
  
  '指定フォルダ上のファイル名を取得
  With Application.FileSearch
    .NewSearch
    .LookIn = strFilePath
    .FileName = "????????_???" & strExtend
    If .Execute(SortBy:=msoSortByFileName, _
      SortOrder:=msoSortOrderAscending) = 0 Then
      Beep
      MsgBox "検索条件を満たすファイルはありません。"
      Exit Function
    End If
    'ファイルの範囲を指定
    For i = 0 To 1
      If i = 0 Then
        lngTop = 1
        lngEnd = .FoundFiles.Count
        lngStep = 1
        strProm = "開始ファイル"
      Else
        lngTop = .FoundFiles.Count
        lngEnd = 1
        lngStep = -1
        strProm = "終了ファイル"
      End If
      Do
        strFileName = GetName(.FoundFiles(lngTop))
        strFileName = InputBox(strProm & "を指定して下さい" _
                  & vbCrLf & "パス、拡張子を抜かして", _
                              , strFileName)
        If strFileName = "" Then
          Exit Function
        End If
        strFileName = strFilePath & "\" & strFileName & strExtend
        For j = lngTop To lngEnd Step lngStep
          If StrComp(strFileName, .FoundFiles(j), _
                    vbTextCompare) = 0 Then
            lngScope(i) = j
            Exit For
          End If
        Next j
        If lngScope(i) = 0 Then
          Beep
          MsgBox "該当するファイルが有りません"
        End If
      Loop Until lngScope(i) > 0
    Next i
    If lngScope(0) > lngScope(1) Then
      i = lngScope(0)
      lngScope(0) = lngScope(1)
      lngScope(1) = i
    End If
    ReDim strData(0 To lngScope(1) - lngScope(0))
    For i = lngScope(0) To lngScope(1)
      strData(i - lngScope(0)) = .FoundFiles(i)
    Next i
  End With

  GetDataFile = True
  
End Function

Private Function GetName(ByVal strValue As String) As String

'  ファイル名からパス、拡張子の除去

  Dim i As Long
  Dim lngPos As Long
  
  lngPos = InStr(1, strValue, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos + 1
    lngPos = InStr(i, strValue, "\", vbBinaryCompare)
  Loop
  strValue = Mid(strValue, i)
  lngPos = InStr(1, strValue, ".", vbBinaryCompare)
  
  GetName = Left(strValue, lngPos - 1)
  
End Function

Private Function Split97(ByVal vntLine As Variant, _
          Optional ByVal strDeli As String = ",") As Variant

'  Excel2000以上の場合必要なし
  
  Dim i As Long
  Dim vntData As Variant
  Dim lngPos As Long
  Dim intDelLen As Integer
  
  intDelLen = Len(strDeli)
  
  i = 0
  ReDim vntData(i)
  lngPos = InStr(1, vntLine, strDeli, vbBinaryCompare)
  Do Until lngPos = 0
    vntData(i) = Left(vntLine, lngPos - 1)
    vntLine = Mid(vntLine, lngPos + intDelLen)
    i = i + 1
    ReDim Preserve vntData(i)
    lngPos = InStr(1, vntLine, strDeli, vbBinaryCompare)
  Loop
  vntData(i) = vntLine
  
  Split97 = vntData
  
End Function

【7156】Re:テキストファイルからのデータ取得につ...
お礼  アート  - 03/8/24(日) 13:28 -

引用なし
パスワード
   ▼Hirofumi さん:
お返事遅くなりどうもすいません。
Hirohumiさんのコードにて問題解決いたしました。
今回のコーティングを題材としてこれからがんばりたいと
思います。
大変ご親切にどうもありがとうございました。

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