[[20170806155239]]　『フォルダにあるCSVの行数一覧の作成方法について』（常磐線出張中）　ページの最後に飛ぶ

『フォルダにあるCSVの行数一覧の作成方法について』（常磐線出張中）

CSVの内容分析をしていますが、ファイルが大量にありすぎてチェックが手間になってます。
行数の多い少ないでCSVのチェック担当者を変えようと思ってまして、そのためにフォルダに入っているCSVのファイル名と行数を一覧化できないかと考えております。
A列ファイル名、B列行数といったイメージです。

過去投稿でありそうな気がしたのですが無いようです。ありそうでない本件、エクセルでCSVをチェックしていることもあり、

教えを請いたく宜しく御願いします。

＜使用 Excel：Excel2016、使用 OS：Windows7 ＞

こんな感じですか。

Option Explicit

Sub Test(FolderName As String)

    Dim buf As String, fn As Integer
    Dim txt As String, lcnt As Long, i As Integer
    Sheet1.Cells(1, 1) = "フォルダー名"
    Sheet1.Cells(1, 2) = "ファイル名"
    Sheet1.Cells(1, 3) = "行数"
　　Sheet1.Cells(2, 1) = FolderName
    'フォルダーの中のCSVファイルを調べる
    buf = Dir(FolderName & "\*.csv")
    Do While buf <> ""
        If Right(buf, 4) = ".csv" Then
            'ファイルを読み込む
            fn = FreeFile
            lcnt = 0
            Open FolderName & "\" & buf For Input As #fn
            '行数を算出する
            Do While Not EOF(fn)
                Line Input #fn, txt
                lcnt = lcnt + 1
            Loop
            Close fn
            'シートに出力する
            Sheet1.Cells(i + 2, 2) = buf
            Sheet1.Cells(i + 2, 3) = lcnt
            txt = ""
            i = i + 1
        End If
        buf = Dir()
    Loop
End Sub

（:;:;:;:;:;） 2017/08/06(日) 16:53

 >A列ファイル名、B列行数といったイメージです。

 Sub test()
     Dim myDir As String, fn As String, n As Long
     With Application.FileDialog(msoFileDialogFolderPicker)
         If .Show Then myDir = .SelectedItems(1) & "\"
     End With
     If myDir = "" Then Exit Sub
     fn = Dir(myDir & "*.csv")
     Do While fn <> ""
         n = n + 1
         Cells(n, 1).Resize(, 2).Value = Array(fn, 0)
         If FileLen(myDir & fn) Then
             Cells(n, 2).Value = _
             UBound(Split(CreateObject("Scripting.FileSystemObject") _
             .OpenTextFile(myDir & fn).ReadAll, vbNewLine)) + 1
         End If
         fn = Dir
     Loop
 End Sub
（ seiya） 2017/08/06(日) 17:05

 :;:;:;:;:;さん、 seiyaさん、有難う御座います。
勝田でロックフェスタがあったとかで常磐線激混みで遅くなってしまいました。

 :;:;:;:;:;さんの方につきましては、エクセルのVBにコピペしたのですが起動のさせ方が分からず断念してしまいました。使い方を教えて頂けると有難いです。

 seiyaさんのほうにつきましては、A列は表示されるのですが全て「1」と表示されてしまいます。
たくさんの行のあるCSVを試してみたのですが上手く使えませんでした。ご確認いただけないでしょうか。

できましたら御返信頂けないでしょうか。
他の方法があれば拘りはありません。

宜しく御願い致します。
（常磐線出張中） 2017/08/06(日) 23:14

CSVにもいろいろあるので、区切り文字と改行コードくらいは教えてもらわないと、思ったように動かない場合があります。
seiyaさんのコード中にある、vbNewLine を、vbLf または vbCr に変えると、どうなるでしょうか？
（???） 2017/08/07(月) 09:28

マクロ→Testを選んで実行できるようにしました。

Option Explicit
Sub Test()

    Dim buf As String, fn As Integer
    Dim fname As Variant, ws As Worksheet
    Dim txt As String, lcnt As Long, i As Integer
    'ダイアログを表示する
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = True
        If .Show Then
            For Each fname In .SelectedItems
                Set ws = Worksheets.Add(, Worksheets(Worksheets.Count))
                ws.Cells(1, 1) = "フォルダー名"
                ws.Cells(1, 2) = "ファイル名"
                ws.Cells(1, 3) = "行数"
                ws.Cells(2, 1) = fname
                'フォルダーの中のCSVファイルを調べる
                buf = Dir(fname & "\*.csv")
                Do While buf <> ""
                    If Right(buf, 4) = ".csv" Then
                        'ファイルを読み込む
                        fn = FreeFile
                        lcnt = 0
                        Open fname & "\" & buf For Input As #fn
                        '行数を算出する
                        Do While Not EOF(fn)
                            Line Input #fn, txt
                            lcnt = lcnt + 1
                        Loop
                        Close fn
                        'シートに出力する
                        ws.Cells(i + 2, 2) = buf
                        ws.Cells(i + 2, 3) = lcnt
                        txt = ""
                        i = i + 1
                    End If
                    buf = Dir()
                Loop
                Set ws = Nothing
            Next
        End If
    End With
End Sub

（:;:;:;:;:;） 2017/08/07(月) 09:49

Sub main()

    Dim FSO As Object, f As Object, wb As Workbook, ar As Variant, p As String
    Cells.Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください。"
        If Not .Show Then MsgBox "キャンセルします。": Exit Sub
        p = .SelectedItems(1)
    End With
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    For Each f In FSO.GetFolder(p).Files
        If LCase(FSO.GetExtensionName(f)) = "csv" Then
            Set wb = Workbooks.Open(Filename:=f, ReadOnly:=True)
            ar = Array(f.Name, wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row)
            wb.Close False
            Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = ar
        End If
    Next f
    Application.ScreenUpdating = True
End Sub
（mm） 2017/08/07(月) 10:01

 > seiyaさんのほうにつきましては、A列は表示されるのですが全て「1」と表示されてしまいます。

 こちらで試してください

 Sub test()
     Dim myDir As String, fn As String, n As Long, txt As String
     With Application.FileDialog(msoFileDialogFolderPicker)
         If .Show Then myDir = .SelectedItems(1) & "\"
     End With
     If myDir = "" Then Exit Sub
     fn = Dir(myDir & "*.csv")
     Do While fn <> ""
         n = n + 1
         Cells(n, 1).Resize(, 2).Value = Array(fn, 0)
         If FileLen(myDir & fn) Then
             txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & fn).ReadAll
             Cells(n, 2).Value = CntLines(txt)
         End If
         fn = Dir
     Loop
 End Sub

 Function CntLines(ByVal txt As String) As Long
    Static RegX As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Global = True
        .Pattern = "[\r\n]+"
        CntLines = .Execute(txt).Count
    End With
 End Function
（ seiya） 2017/08/07(月) 10:13

皆さん有難う御座います。

mmさんの方法が空行もカウントしてしまいますが行数が確りと表示されました。
空行も一行といわれれば一行ですし、CSVは色々な体裁があるのですね・・・。
色々とご迷惑をお掛けしました。
（常磐線出張中） 2017/08/07(月) 23:52

コメント返信：

[ 一覧(最新更新順) ]

[[20170806155239]] 『フォルダにあるCSVの行数一覧の作成方法について』（常磐線出張中） ページの最後に飛ぶ

[[20170806155239]]　『フォルダにあるCSVの行数一覧の作成方法について』（常磐線出張中）　ページの最後に飛ぶ