Excel VBA質問箱 IV

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

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


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

【20321】同一フォルダ内に保存しているファイルをEXCELシートに追加読み込み ムシキング 04/12/5(日) 14:40 質問[未読]
【20324】Re:同一フォルダ内に保存しているファイル... [名前なし] 04/12/5(日) 15:01 発言[未読]
【20326】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/5(日) 15:27 発言[未読]
【20328】Re:同一フォルダ内に保存しているファイル... [名前なし] 04/12/5(日) 16:33 回答[未読]
【20329】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/5(日) 17:27 回答[未読]
【20330】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/5(日) 21:50 回答[未読]
【20331】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/5(日) 23:22 発言[未読]
【20344】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:15 回答[未読]
【20345】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:22 回答[未読]
【20346】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:40 回答[未読]
【20348】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/6(月) 22:41 質問[未読]
【20382】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/7(火) 19:26 回答[未読]
【20477】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/9(木) 23:01 発言[未読]
【20515】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/10(金) 21:04 回答[未読]
【20676】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/14(火) 20:39 お礼[未読]
【20677】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/14(火) 21:17 回答[未読]

【20321】同一フォルダ内に保存しているファイルを...
質問  ムシキング  - 04/12/5(日) 14:40 -

引用なし
パスワード
   教えて下さい!!!!!
Cドライブの「RLEファイル格納」というフォルダ内に数十個のフォルダがあります。
各フォルダ内には、拡張子「.RLE」というファイル(カンマ区切り)が数十個あります。
名称に規則性はありません。

これをフォルダごとに1つのEXCELの同一シートに追加読み込みした後、E列の「Voiding」の数をカウントした結果をメッセージBOXで知らせてくれるというものを
欲しております。

処理するフォルダの選択は、ファイルを開くのダイアログボックスが開くものが良いです。

お恥ずかしいのですが、今までは1つ1つファイルを開いてCOUNTIFを作成して対応していました。
何卒よろしくお願いします。

【20324】Re:同一フォルダ内に保存しているファイ...
発言  [名前なし]  - 04/12/5(日) 15:01 -

引用なし
パスワード
   まず、ご自分でどこまでやってどこがうまくいかなかったのか
まとめたほうがいいと思いますよ。

こういうコードを書いて、ここの部分がうまくいかないとか
書いてあると、レスが付きやすいかもです。

【20326】Re:同一フォルダ内に保存しているファイ...
発言  ムシキング  - 04/12/5(日) 15:27 -

引用なし
パスワード
   Sub Macro1()
  Application.Dialogs(xlDialogOpen).Show
  Range("G1").Select
  ActiveCell.FormulaR1C1 = "=COUNTIF(C[-2],""Voiding"")"
End Sub

ぶっちゃけ、数百個のファイルをダイアログボックスから1つ1つ開いてカウントするのに、疲れ果てて途方に暮れている次第です。
助けて下さい!

【20328】Re:同一フォルダ内に保存しているファイ...
回答  [名前なし]  - 04/12/5(日) 16:33 -

引用なし
パスワード
   [#12348]を参考にされるとよろしいかと。

【20329】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/5(日) 17:27 -

引用なし
パスワード
   意味の理解が出来ない所が有るので上手く行くか?
全てのフォルダのデータを1つのBookに読み込みます
また、各フォルダのデータは、1枚づつのシートに成ります
「Voiding」のカウントは、各シートの最終行の一つ下に書き込まれます

Option Explicit

Public Sub ReadRle()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWrite As Long
  Dim vntVoiding As Variant
  Dim blnHeader As Boolean
  Dim wkbNewBook As Workbook
  Dim wksNewSheet As Worksheet
  
'  Application.ScreenUpdating = False
  
  '新規Bookを追加
  Set wkbNewBook = Workbooks.Add
  'Voidingカウント用の変数を初期化
  ReDim vntVoiding(1 To 2, 1 To 2)
  vntVoiding(1, 1) = "Voiding小計"
  vntVoiding(2, 1) = "Voiding合計"
  
  Do
    'ファイルを開くダイアログを表示してファイル名を取得
    If GetReadFile(vntFileNames, ThisWorkbook.Path, True) Then
      '新規Bookに書き込み用シートを追加
      With wkbNewBook.Worksheets
        Set wksNewSheet = .Add(After:=.Item(.Count))
      End With
      'Voidingカウント用の変数をクリア
      vntVoiding(1, 2) = 0
      '書き込み行の初期値
      lngWrite = 1
      '先頭行を書き込み
      blnHeader = True
      '取得したファイル名全てに繰り返し
      For i = 1 To UBound(vntFileNames)
        '書き込み用シートに出力
        CSVRead vntFileNames(i), wksNewSheet, _
            vntVoiding, lngWrite, 1, blnHeader, ","
        '先頭行をスッキプ
        'blnHeader = False
      Next i
      'Voidingカウント総数用の変数にVoidingカウントを加算
      vntVoiding(2, 2) = vntVoiding(2, 2) + vntVoiding(1, 2)
      '最終行の1行下にVoidingカウントを書き込み
      lngWrite = lngWrite + 1
      With wksNewSheet
        .Cells(lngWrite, 4).Resize(2, 2).Value = vntVoiding
      End With
      'ファイル名取得用変数の初期化
      vntFileNames = ""
    End If
  Loop Until MsgBox("続けますか?", vbInformation + vbYesNo, "処理継続") = vbNo
  
  Set wksNewSheet = Nothing
  Set wkbNewBook = Nothing
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              ByRef vntTotal As Variant, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1, _
              Optional ByRef blnHeader As Boolean = True, _
              Optional strDelim As String = ",")
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strLine As String
  Dim blnMulti As Boolean
  Dim strRec As String
  
  dfn = FreeFile
  Open strFileName For Input As dfn
  
  Do Until EOF(dfn)
    Line Input #dfn, strLine
    strRec = strRec & strLine
    vntField = SplitCsv(strRec, strDelim, , , blnMulti)
    If blnMulti Then
      strRec = strRec & vbLf
    Else
      If blnHeader Then
        If vntField(4) = "Voiding" Then
          vntTotal(1, 2) = vntTotal(1, 2) + 1
        End If
        With wksWrite.Cells(lngRow, lngCol)
          .Offset.Resize(, UBound(vntField) + 1) = vntField
        End With
        lngRow = lngRow + 1
      End If
      strRec = ""
      blnHeader = True
    End If
  Loop
  
  Close #dfn
  
End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

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

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "RLE File (*.RLE),*.RLE," _
        & "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

【20330】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/5(日) 21:50 -

引用なし
パスワード
   もし、「Voiding」のカウント一覧表みたいな物が必要なら
2つのプロシージャを以下の様に変更して下さい

Public Sub ReadRle()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWrite As Long
  Dim blnHeader As Boolean
  Dim wkbNewBook As Workbook
  Dim wksNewSheet As Worksheet
  Dim wksVoiding As Worksheet
  Dim vntVoiding As Variant
  Dim lngVoidingRow As Long
  Dim strPath As String
  Dim objFso As Object
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
'  Application.ScreenUpdating = False
  
  '新規Bookを追加
  Set wkbNewBook = Workbooks.Add
  Set wksVoiding = wkbNewBook.Worksheets("Sheet1")
  lngVoidingRow = 1
  wksVoiding.Cells(lngVoidingRow, "A").Resize(, 4).Value _
      = Array("Folder", "FileName", "Voiding", "Voiding累計")
  lngVoidingRow = lngVoidingRow + 1
  'Voidingカウント用の変数を初期化
  ReDim vntVoiding(1 To 3)
  
  'ファイルを開くダイアログを表示してファイル名を取得
  Do While GetReadFile(vntFileNames, ThisWorkbook.Path, True)
    '新規Bookに書き込み用シートを追加
    With wkbNewBook.Worksheets
      Set wksNewSheet = .Add(After:=.Item(.Count))
    End With
    strPath = objFso.GetParentFolderName(vntFileNames(1))
    wksVoiding.Cells(lngVoidingRow, 1).Value = strPath
    '書き込み行の初期値
    lngWrite = 1
    '先頭行を書き込み
    blnHeader = True
    '取得したファイル名全てに繰り返し
    For i = 1 To UBound(vntFileNames)
      'Voidingカウント用の変数を初期設定
      vntVoiding(1) = objFso.GetBaseName(vntFileNames(i))
      vntVoiding(2) = 0
      '書き込み用シートに出力
      CSVRead vntFileNames(i), objFso, wksNewSheet, _
            vntVoiding, lngWrite, 1, blnHeader, ","
      '先頭行をスッキプ
      'blnHeader = False
      'Voidingカウント総数用の変数にVoidingカウントを加算
      vntVoiding(3) = vntVoiding(3) + vntVoiding(2)
      With wksVoiding
        .Cells(lngVoidingRow, 2).Resize(, 3).Value = vntVoiding
        lngVoidingRow = lngVoidingRow + 1
      End With
    Next i
    wksNewSheet.Name = NameLetter(strPath)
    'ファイル名取得用変数の初期化
    vntFileNames = ""
  Loop
  
  Set wksNewSheet = Nothing
  Set wkbNewBook = Nothing
  Set wksVoiding = Nothing
  Set objFso = Nothing
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal objFso As Object, _
              ByRef wksWrite As Worksheet, _
              ByRef vntTotal As Variant, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1, _
              Optional ByRef blnHeader As Boolean = True, _
              Optional strDelim As String = ",")
  
  Dim vntField As Variant
  Dim strLine As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim wkbParent As Workbook
  Dim objFileStr As Object
  Const ForReading = 1
  
  Set wkbParent = wksWrite.Parent
  
  '指定ファイルを読み込みモードでOpen
  Set objFileStr = objFso.OpenTextFile(strFileName, ForReading)
  
  With objFileStr
    Do Until .AtEndOfStream
      strLine = .ReadLine
      strRec = strRec & strLine
      vntField = SplitCsv(strRec, strDelim, , , blnMulti)
      If blnMulti Then
        strRec = strRec & vbLf
      Else
        If blnHeader Then
          If vntField(4) = "Voiding" Then
            vntTotal(2) = vntTotal(2) + 1
          End If
          With wksWrite.Cells(lngRow, lngCol)
            .Offset.Resize(, UBound(vntField) + 1) = vntField
          End With
          lngRow = lngRow + 1
          If lngRow > 65536 Then
            lngRow = 1
            With wkbParent.Worksheets
              Set wksWrite = .Add(After:=.Item(.Count))
            End With
          End If
        End If
        strRec = ""
        blnHeader = True
      End If
    Loop
    .Close
  End With
  
  Set objFileStr = Nothing
  Set wkbParent = Nothing
  
End Sub

'其れと、以下のプロシージャを追加して下さ

Private Function NameLetter(ByVal strName As String) As String

'  シート名のチェック
  
  Dim i As Long
  Dim vntLetter As Variant
  Dim lngPos As Long
  
  'シート名として使用不可能な文字の一覧を作成
  vntLetter = Array(":", "\", "?", "[", "]", "/", "*")
  
  '一覧全てに就いて
  For i = 0 To UBound(vntLetter, 1)
    '引数の文字列に一覧の文字が含まれるか探索
    lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
    '引数の文字列に一覧の文字が無くなるまで繰り返し
    Do Until lngPos = 0
      '有る場合、"_"に置換
      strName = Left(strName, lngPos - 1) _
            & "_" & Mid(strName, lngPos + 1)
      '引数の文字列に一覧の文字が含まれるか探索
      lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
    Loop
  Next i
  
  '戻り値として、置換後の文字列を返す
  NameLetter = strName
  
End Function

【20331】Re:同一フォルダ内に保存しているファイ...
発言  ムシキング  - 04/12/5(日) 23:22 -

引用なし
パスワード
   Hirofumiさん、本当に有難うございます。m(__)m
途中で止まってしまうのですが、どうしたら良いですか?

'ファイルを開くダイアログを表示してファイル名を取得
  Do While GetReadFile(vntFileNames, ThisWorkbook.Path, True)
の、GetReadFileのところで。
subまたはfunctionが定義されていません。のメッセージが出ます。。

全くの初心者なもので、見当違いな質問でしたらごめんなさい。
ゼロからのご指導で申し訳ありませんが、何卒お願いします。

【20344】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/6(月) 19:15 -

引用なし
パスワード
   >途中で止まってしまうのですが、どうしたら良いですか?
>
>'ファイルを開くダイアログを表示してファイル名を取得
>  Do While GetReadFile(vntFileNames, ThisWorkbook.Path, True)
>の、GetReadFileのところで。
>subまたはfunctionが定義されていません。のメッセージが出ます。。
>
>全くの初心者なもので、見当違いな質問でしたらごめんなさい。
>ゼロからのご指導で申し訳ありませんが、何卒お願いします。

これは、GetReadFileと言うプロシージャが無い事により起こります

【20329】Re:同一フォルダ内に保存しているファイ...   
Hirofumi - 04/12/5(日) 17:27 - 

の私のレスで、以下の様な、四つのプロシージャが有った筈です

Public Sub ReadRle()
 ・
End Sub

Private Sub CSVRead(ByVal strFileName As String,・・)
 ・
End Sub

Private Function SplitCsv(ByVal strLine As String,・・) As Variant
 ・
End Function

Private Function GetReadFile(vntFileNames As Variant, ・・) As Boolean
 ・  
End Function

此れを全て、同じ標準モジュールに記述して下さい
そして、その中の、

Public Sub ReadRle()
 ・
End Sub

Private Sub CSVRead(ByVal strFileName As String,・・)
 ・
End Sub

上記2つのプロシージャを、
 
【20330】Re:同一フォルダ内に保存しているファイ...   
Hirofumi - 04/12/5(日) 21:50 - 

のレスで書いている、

Public Sub ReadRle()
 ・
End Sub

Private Sub CSVRead(ByVal strFileName As String,・・)
 ・
End Sub

のプロシージャと入れ替えて(書き換えて)下さい
また、同じ標準モジュールに、

【20330】Re:同一フォルダ内に保存しているファイ...   
Hirofumi - 04/12/5(日) 21:50 - 

で書いた、

Private Function NameLetter(ByVal strName As String) As String
 ・  
End Function

のプロシージャを追加して下さい

【20345】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/6(月) 19:22 -

引用なし
パスワード
   詰まり、同一の標準モジュールに、以下の5つのプロシージャが有る事に成ります
これは、5つのプロシージャで1セットのマクロに成って居て、
「Sub ReadRle」以外の4つのプロシージャは、「Sub ReadRle」から呼び出されて使用されます

Public Sub ReadRle()
 ・
End Sub

Private Sub CSVRead(ByVal strFileName As String,・・)
 ・
End Sub

Private Function SplitCsv(ByVal strLine As String,・・) As Variant
 ・
End Function

Private Function GetReadFile(vntFileNames As Variant, ・・) As Boolean
 ・  
End Function

Private Function NameLetter(ByVal strName As String) As String
 ・  
End Function

【20346】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/6(月) 19:40 -

引用なし
パスワード
   あ!、まだ言い忘れが有った
「Voidingカウント一覧」は、Sheet1に作成されます
其れに伴い、以下の部分を追加して下さい

「Public Sub ReadRle()」の中で、

 ・
 ・
  '新規Bookを追加
  Set wkbNewBook = Workbooks.Add
  Set wksVoiding = wkbNewBook.Worksheets("Sheet1")
  lngVoidingRow = 1
  wksVoiding.Cells(lngVoidingRow, "A").Resize(, 4).Value _
      = Array("Folder", "FileName", "Voiding", "Voiding累計")
  lngVoidingRow = lngVoidingRow + 1
  wksVoiding.Name = "Voidingカウント一覧" '★この行追加
  'Voidingカウント用の変数を初期化
 ・
 ・
    '新規Bookに書き込み用シートを追加
    With wkbNewBook.Worksheets
      Set wksNewSheet = .Add(After:=.Item(.Count))
    End With
    strPath = objFso.GetParentFolderName(vntFileNames(1))
    wksVoiding.Cells(lngVoidingRow, 1).Value = strPath
    vntVoiding(3) = 0 '★この行追加
    '書き込み行の初期値
 ・
 ・

また、使い方で、「ファイルを開く」ダイアログのキャンセルボタンを押すと
マクロが、終了しますのでヨロシク

【20348】Re:同一フォルダ内に保存しているファイ...
質問  ムシキング  - 04/12/6(月) 22:41 -

引用なし
パスワード
   Hirofumiさん、お手数をお掛けしています。。。
下記の「If vntField(4) = "Voiding" Then」で止まってしまいます。
現在自宅で走らせていますが、97なのですが関係有りますか?
実際会社で使うのは、XPです。
私の追加・差し替えのやり方が悪いだけでしょうか?
全て通しで提供頂けたらと思います。
手の掛かる子で、誠に恐縮です。m(__)m

'指定ファイルを読み込みモードでOpen
  Set objFileStr = objFso.OpenTextFile(strFileName, ForReading)
 
  With objFileStr
    Do Until .AtEndOfStream
      strLine = .ReadLine
      strRec = strRec & strLine
      vntField = SplitCsv(strRec, strDelim, , , blnMulti)
      If blnMulti Then
        strRec = strRec & vbLf
      Else
        If blnHeader Then
          If vntField(4) = "Voiding" Then
            vntTotal(2) = vntTotal(2) + 1
          End If
          With wksWrite.Cells(lngRow, lngCol)
            .Offset.Resize(, UBound(vntField) + 1) = vntField
          End With
          lngRow = lngRow + 1
          If lngRow > 65536 Then
            lngRow = 1
            With wkbParent.Worksheets
              Set wksWrite = .Add(After:=.Item(.Count))
            End With
          End If
        End If
        strRec = ""
        blnHeader = True
      End If
    Loop
    .Close
  End With
 

【20382】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/7(火) 19:26 -

引用なし
パスワード
   >下記の「If vntField(4) = "Voiding" Then」で止まってしまいます。

どの様な、止まり方をしているのが不明なので、善く解りませんが?
多分、データが、5フィールド分無いのでは?
E列に有る「Voiding」をカウントと有るので、
先頭から5番目のフィールド(配列が、0から始まるので)を見ているのですが?
実際にどの様なデータに成って居るのかサンプルをUpして下さい
ここで、見せてはマズイ部分は、「AAA」とかでも善いですから

>現在自宅で走らせていますが、97なのですが関係有りますか?
Excel97で問題は無いと思います
何故なら、此れを書いているのが、Win98、Excel97ですので

>全て通しで提供頂けたらと思います。

Option Explicit

Public Sub ReadRle2()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWrite As Long
  Dim blnHeader As Boolean
  Dim wkbNewBook As Workbook
  Dim wksNewSheet As Worksheet
  Dim wksVoiding As Worksheet
  Dim vntVoiding As Variant
  Dim lngVoidingRow As Long
  Dim strPath As String
  Dim objFso As Object
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
'  Application.ScreenUpdating = False
  
  '新規Bookを追加
  Set wkbNewBook = Workbooks.Add
  Set wksVoiding = wkbNewBook.Worksheets("Sheet1")
  lngVoidingRow = 1
  wksVoiding.Cells(lngVoidingRow, "A").Resize(, 4).Value _
      = Array("Folder", "FileName", "Voiding", "Voiding累計")
  lngVoidingRow = lngVoidingRow + 1
  wksVoiding.Name = "Voidingカウント一覧" '★この行追加
  'Voidingカウント用の変数を初期化
  ReDim vntVoiding(1 To 3)
  
  'ファイルを開くダイアログを表示してファイル名を取得
  Do While GetReadFile(vntFileNames, ThisWorkbook.Path, True)
    '新規Bookに書き込み用シートを追加
    With wkbNewBook.Worksheets
      Set wksNewSheet = .Add(After:=.Item(.Count))
    End With
    strPath = objFso.GetParentFolderName(vntFileNames(1))
    wksVoiding.Cells(lngVoidingRow, 1).Value = strPath
    vntVoiding(3) = 0 '★この行追加
    '書き込み行の初期値
    lngWrite = 1
    '先頭行を書き込み
    blnHeader = True
    '取得したファイル名全てに繰り返し
    For i = 1 To UBound(vntFileNames)
      'Voidingカウント用の変数を初期設定
      vntVoiding(1) = objFso.GetBaseName(vntFileNames(i))
      vntVoiding(2) = 0
      '書き込み用シートに出力
      CSVRead vntFileNames(i), objFso, wksNewSheet, _
            vntVoiding, lngWrite, 1, blnHeader, ","
      '先頭行をスッキプ
      'blnHeader = False
      'Voidingカウント総数用の変数にVoidingカウントを加算
      vntVoiding(3) = vntVoiding(3) + vntVoiding(2)
      With wksVoiding
        .Cells(lngVoidingRow, 2).Resize(, 3).Value = vntVoiding
        lngVoidingRow = lngVoidingRow + 1
      End With
    Next i
    wksNewSheet.Name = NameLetter(strPath)
    'ファイル名取得用変数の初期化
    vntFileNames = ""
  Loop
  
  Set wksNewSheet = Nothing
  Set wkbNewBook = Nothing
  Set wksVoiding = Nothing
  Set objFso = Nothing
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal objFso As Object, _
              ByRef wksWrite As Worksheet, _
              ByRef vntTotal As Variant, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1, _
              Optional ByRef blnHeader As Boolean = True, _
              Optional strDelim As String = ",")
  
  Dim vntField As Variant
  Dim strLine As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim wkbParent As Workbook
  Dim objFileStr As Object
  Const ForReading = 1
  
  Set wkbParent = wksWrite.Parent
  
  '指定ファイルを読み込みモードでOpen
  Set objFileStr = objFso.OpenTextFile(strFileName, ForReading)
  
  With objFileStr
    Do Until .AtEndOfStream
      strLine = .ReadLine
      strRec = strRec & strLine
      vntField = SplitCsv(strRec, strDelim, , , blnMulti)
      If blnMulti Then
        strRec = strRec & vbLf
      Else
        If blnHeader Then
          If UBound(vntField) >= 4 Then
            If vntField(4) = "Voiding" Then
              vntTotal(2) = vntTotal(2) + 1
            End If
          End If
          With wksWrite.Cells(lngRow, lngCol)
            .Offset.Resize(, UBound(vntField) + 1) = vntField
          End With
          lngRow = lngRow + 1
          If lngRow > 65536 Then
            lngRow = 1
            With wkbParent.Worksheets
              Set wksWrite = .Add(After:=.Item(.Count))
            End With
          End If
        End If
        strRec = ""
        blnHeader = True
      End If
    Loop
    .Close
  End With
  
  Set objFileStr = Nothing
  Set wkbParent = Nothing
  
End Sub

Private Function NameLetter(ByVal strName As String) As String

'  シート名のチェック
  
  Dim i As Long
  Dim vntLetter As Variant
  Dim lngPos As Long
  
  'シート名として使用不可能な文字の一覧を作成
  vntLetter = Array(":", "\", "?", "[", "]", "/", "*")
  
  '一覧全てに就いて
  For i = 0 To UBound(vntLetter, 1)
    '引数の文字列に一覧の文字が含まれるか探索
    lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
    '引数の文字列に一覧の文字が無くなるまで繰り返し
    Do Until lngPos = 0
      '有る場合、"_"に置換
      strName = Left(strName, lngPos - 1) _
            & "_" & Mid(strName, lngPos + 1)
      '引数の文字列に一覧の文字が含まれるか探索
      lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
    Loop
  Next i
  
  '戻り値として、置換後の文字列を返す
  NameLetter = strName
  
End Function

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As Variant
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

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

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "RLE File (*.RLE),*.RLE," _
        & "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

【20477】Re:同一フォルダ内に保存しているファイ...
発言  ムシキング  - 04/12/9(木) 23:01 -

引用なし
パスワード
   Hirofumiさん、なかなか来れなくてお返事出来なくてすいません。

まるまる送って頂いたもので、試してみました。
2つめのファイルを処理したところで止まりました。
wksNewSheet.Name = NameLetter(strPath)

Voidingカウント一覧のシートには、下記が残りました。
Folder              FileName    Voiding    Voiding累計
C:\RLEファイル格納\041209    1C8MPQNN    78    78
C:\RLEファイル格納\041209    1CIT1B89    114    114

さらに、またお願いなのですが。
ダイアログから選択する形を希望したのですが、これはやめて。
C:\RLEファイル格納に保存してあるフォルダごとに一発でカウント出来るようにはなりますか?

C:\RLEファイル格納
 →041209
   →aaaa.RLE :Voiding 10
   →bbbb.RLE :Voiding 10
   →cccc.RLE :Voiding 10
 →041210
   →AAAA.RLE :Voiding 20
   →BBBB.RLE :Voiding 20
   →CCCC.RLE :Voiding 20

上記のような保存状況で、VBAを走らせた結果、下記のような結果がVoidingカウント一覧のシートに出力したいです。

Folder              FileName    Voiding    Voiding累計
C:\RLEファイル格納\041209    aaaa.RLE    10    10
C:\RLEファイル格納\041209    bbbb.RLE    10    20
C:\RLEファイル格納\041209    cccc.RLE    10    30
C:\RLEファイル格納\041210    AAAA.RLE    20    20
C:\RLEファイル格納\041210    BBBB.RLE    20    40
C:\RLEファイル格納\041210    CCCC.RLE    20    60

重ね重ねのお願いで恐縮ですが、よろしくお願いします。

【20515】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/10(金) 21:04 -

引用なし
パスワード
   >まるまる送って頂いたもので、試してみました。
>2つめのファイルを処理したところで止まりました。
>wksNewSheet.Name = NameLetter(strPath)

止まりましたとは?、如何言う意味で?
エラーが出たならどの様なエラーが出たのですか?
其れが解らなければ、直し様が有りません

>Voidingカウント一覧のシートには、下記が残りました。
>Folder              FileName    Voiding    Voiding累計
>C:\RLEファイル格納\041209    1C8MPQNN    78    78
>C:\RLEファイル格納\041209    1CIT1B89    114    114

此れを見ると、多分「ファイルを開く」ダイアログで、1つづつファイルを選択しているようですね?
其の場合、Pathをシート名にして居るので、同じ名前のシートを作ろうとしますのでエラーに成ります
ここで、表示される「ファイルを開く」ダイアログは、マルチセレクトなので、
同一フォルダのファイルは、一遍に選択してください(Shiftキーを押しながら選択、
若しくは、Ctrlキーを押しながら選択)
そうすれば、選択されたファイルが同じシートに続けて読みこまれます

>さらに、またお願いなのですが。
>ダイアログから選択する形を希望したのですが、これはやめて。
>C:\RLEファイル格納に保存してあるフォルダごとに一発でカウント出来るようにはなりますか?
>
>C:\RLEファイル格納
> →041209
>   →aaaa.RLE :Voiding 10
>   →bbbb.RLE :Voiding 10
>   →cccc.RLE :Voiding 10
> →041210
>   →AAAA.RLE :Voiding 20
>   →BBBB.RLE :Voiding 20
>   →CCCC.RLE :Voiding 20
>
>上記のような保存状況で、VBAを走らせた結果、下記のような結果がVoidingカウント一覧のシートに出力したいです。
>
>Folder              FileName    Voiding    Voiding累計
>C:\RLEファイル格納\041209    aaaa.RLE    10    10
>C:\RLEファイル格納\041209    bbbb.RLE    10    20
>C:\RLEファイル格納\041209    cccc.RLE    10    30
>C:\RLEファイル格納\041210    AAAA.RLE    20    20
>C:\RLEファイル格納\041210    BBBB.RLE    20    40
>C:\RLEファイル格納\041210    CCCC.RLE    20    60

そう言う使い方をすれば、上記(チョト違うけど)の様に成ると思いますが?
まず、今のコードで読めないのに、仕様を変更しても無意味では?

【20676】Re:同一フォルダ内に保存しているファイ...
お礼  ムシキング  - 04/12/14(火) 20:39 -

引用なし
パスワード
   Hirofumiさん、マルチセレクトでやっていませんでした。。。
さっそくやってみました。
完璧です。(感謝2.)

また「ムシキング」の投稿が目に付きましたら、ぜひぜひお助け下さい。
参考までに良かったら教えて頂きたいのですが。
Hirofumiさんは、どんな勉強で習得されたのですか?
それ関係のお仕事に付かれているのですか?

私もこれを機に避けていた勉強を始め、業務に生かして行きたいと思います。
本当に有難うございました。

【20677】Re:同一フォルダ内に保存しているファイ...
回答  Hirofumi  - 04/12/14(火) 21:17 -

引用なし
パスワード
   >参考までに良かったら教えて頂きたいのですが。
>Hirofumiさんは、どんな勉強で習得されたのですか?
>それ関係のお仕事に付かれているのですか?

残念ながら、Excelを仕事で使った事は殆有りません
特にVBAの勉強はしていませんが、昔、VBAのご先祖さまを使った事が有るので、
少々解る程度です
ただ私の言える事は、こう言う物は、いっぱい書いて、いっぱいエラーを出して、
いっぱい悩まなければ、上手い事書けないような気がします
昔、1つのコードを1か月悩んだ事も有った様な?

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