Excel VBA質問箱 IV

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

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


21340 / 76738 ←次へ | 前へ→

【60799】フォルダ名とテキストファイルの読み込み
質問  たかし  - 09/3/16(月) 9:56 -

引用なし
パスワード
   いつもお世話になっています。
今回も自分なりに試行錯誤してみたのですが、エラーを回避できなかったので、お力をお借りしたく、投稿しました。

"TEST"フォルダ内に"1234_ABCD"の形式のフォルダが複数格納されている。
"1234_ABCD"フォルダ内に、"1234.txt"ファイルが格納されている。

マクロ1で、フォルダ名を"_"で区切った"1234"と"ABCD"に分けてA列とB列に入力
 TESTフォルダ内に、"AAA.TXT"のダミーテキストファイルを作っておき、
 これを選択すると、フォルダ名を"_"で区切ってエクセルに入力できるように
 マクロを作成しました。(正常に動作します)
マクロ2で、1234.txt内の文字列を検索し、該当する文字列をC列とD列に入力
 対象の"1234.txt"を直接選択すれば、検索結果をエクセルに取り込める
 正常に動作しています。

マクロ1、マクロ2は、それぞれ単独では動作するのですが、1回のマクロにしたいのです。
そこで、下記マクロを作成したのですが、
  Set fnow = fso.OpenTextFile(FPa, ForReading)
で、”実行時エラー 5 プロシージャの呼び出し、または引数が不正です”
エラーが出てしまいます。
恐らく"FP"の設定がおかしいのではないかと思うのですが、どなたかアドバイスをお願い致します。

作成マクロ
Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String

  strFilter = "全て (*.*),*.*"
  strInitialFile = vntFileName
  If strFilePath <> "" Then
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True

End Function

Sub Folder()
 Dim fso As Object, fnow As Object
 Dim MyPath As String, folpath As String, folmei As String, fmei As String
 Dim fbasename As String, kaku As String, strPath As String
 Dim vntFileName As Variant, Name As Variant, FP As Variant
 Dim DataJ As Range
 Dim i, j

  Set fso = CreateObject("Scripting.FileSystemObject")
  i = Worksheets("LIST").Range("A65536").End(xlUp).Row
  
  If GetWriteFile(vntFileName, strPath) Then

   MyPath = vntFileName            'ファイルのフルパス
   folpath = fso.getparentfoldername(MyPath) & "\"  'フォルダのパス
   folmei = fso.getfolder(folpath).Name    'フォルダ名
   fmei = FSO.getfile(MyPath).Name       'ファイル名
   fbasename = FSO.getbasename(MyPath)'ファイル名から拡張子を除いた部分
   kaku = FSO.GetExtensionName(MyPath)     '拡張子
   MyName = Dir(folpath, vbDirectory)  '最初のフォルダ名を返します。
   Worksheets("TEMP").Range("A1").Value = folpath
   
   Do While MyName <> ""            ' ループを開始します。
    '現在のフォルダと親フォルダは無視します。
    If MyName <> "." And MyName <> ".." Then
     'ビット単位の比較を行い、MyName がフォルダかどうかを調べます。
     If (GetAttr(folpath & MyName) And vbDirectory) = vbDirectory Then
       'フォルダであれば、それを表示します。
       i = i + 1
       FName = Split(MyName, "_")
       Worksheets("LIST").Cells(i, 1).Value = FName(0)
       Worksheets("LIST").Cells(i, 2).Value = FName(1)
     End If
    End If
    MyName = Dir          ' 次のフォルダ名を返します。
   Loop
  End If
  With Worksheets("LIST")
   j = .Range("A65536").End(xlUp).Row
   For k = 2 To j
    .Cells(k, 5).Value = Worksheets("TEMP").Range("A1").Value & .Range("A" & k).Value & _
                     "_" & .Range("B" & k).Value & "\" & .Range("A" & k).Value & ".xml"
                     
    
    FP = folpath & FName(0) & "_" & FName(1) & "\" & FName(0) & ".txt"
    
     Sheets("LIST").Cells(k, 7) = FPa
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set fnow = fso.OpenTextFile(FPa, ForReading)
    Do While fnow.AtEndOfStream <> True
      temp = fnow.readline
       
       If temp Like "*<name>*" Then
        TANTO = Split(Replace(temp, "<", ">"), ">")
        Sheets("LIST").Cells(k, 6) = TANTO(1)
       ElseIf temp Like "*<element id=*" Then
        BLID = Split(temp, """")
        BLID1 = BLID(1)
        Sheets("LIST").Cells(k, 7 + BLID1 * 2) = BLID1
       ElseIf temp Like "*<machine_type>*" Then
        BLDX = Split(Replace(temp, ">", "<"), "<")
        Sheets("LIST1").Cells(k, 8 + BLID1 * 2) = BLDX(2)
       End If
    Loop
    fnow.Close
    Set fnow = Nothing
   Next
  End With
  
End Sub
0 hits

【60799】フォルダ名とテキストファイルの読み込み たかし 09/3/16(月) 9:56 質問
【60800】Re:フォルダ名とテキストファイルの読み込み neptune 09/3/16(月) 10:26 発言
【60801】Re:フォルダ名とテキストファイルの読み込み たかし 09/3/16(月) 10:47 質問
【60802】Re:フォルダ名とテキストファイルの読み込み たかし 09/3/16(月) 11:01 お礼

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