質問です

c:\test\のホルダーに複数のtxtファイルがあります
ファイルの中の行数(件数)を数えてファイルの最後に
その数を記入するマクロはできますか

AAAA.txt
ファイル名の最後に
AAAA_12345.txt
と数字の前にアンダーバーを入れて数字を記入する
複数のファイルは順番に連続して数えて記入する
データは1行目からです列は複数あります
よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/11/09 19:48:41
  • 終了:2012/11/10 14:08:04

ベストアンサー

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/11/09 20:17:23

ポイント80pt

Excelのマクロでよければ、下記をお試しください。
なお、Windows環境なので、改行はCR+LFを1行として数えます。

Option Explicit

'拡張子を除く
Function GetFNameFromFStr(sFileName As String) As String
    Dim sFileStr As String
    Dim lFindPoint As Long
    Dim lStrLen As Long
    
    '文字列の右端から"."を検索し、左端からの位置を取得する
    lFindPoint = InStrRev(sFileName, ".")
    
    '拡張子を除いたファイル名の取得
    sFileStr = Left(sFileName, lFindPoint - 1)

    GetFNameFromFStr = sFileStr
End Function

'1ファイル処理
Function countLine(path As String, fname As String) As Long
    Dim buf As String
    Dim cnt As Long
    Dim dc As Object
    
    Set dc = CreateObject("Scripting.Dictionary")
    '行数カウント
    cnt = 0
    Open path & fname For Input As #1
    Do Until EOF(1)
        Line Input #1, buf
        cnt = cnt + 1
    Loop
    Close #1
    countLine = cnt
End Function

'ファイル探索+ファイル名変更
Sub hogeConv(path As String, ext As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String, fname As String
    Dim n As Long
    
    '処理対象ファイル探索+処理実行
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
    Set re = CreateObject("VBScript.RegExp")
    pat = "\." & ext & "$"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        For Each flist In fcol
            fname = GetFNameFromFStr(flist.name)
            Set remat = .Execute(flist.name)
            If remat.Count > 0 Then
                n = countLine(path, flist.name)
                Name path & fname & "." & ext As path & fname & "_" & n & "." & ext
            End If
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call hogeConv("C:/test/", "txt")
End Sub

他3件のコメントを見る
id:oil999

56行目を以下のように変更してください。

                Name path & fname & "." & ext As path & fname & n & "." & ext

2012/11/10 11:32:25
id:inosisi4141

ありがとうございました
完璧です

2012/11/10 13:57:22

その他の回答(1件)

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/11/09 20:17:23ここでベストアンサー

ポイント80pt

Excelのマクロでよければ、下記をお試しください。
なお、Windows環境なので、改行はCR+LFを1行として数えます。

Option Explicit

'拡張子を除く
Function GetFNameFromFStr(sFileName As String) As String
    Dim sFileStr As String
    Dim lFindPoint As Long
    Dim lStrLen As Long
    
    '文字列の右端から"."を検索し、左端からの位置を取得する
    lFindPoint = InStrRev(sFileName, ".")
    
    '拡張子を除いたファイル名の取得
    sFileStr = Left(sFileName, lFindPoint - 1)

    GetFNameFromFStr = sFileStr
End Function

'1ファイル処理
Function countLine(path As String, fname As String) As Long
    Dim buf As String
    Dim cnt As Long
    Dim dc As Object
    
    Set dc = CreateObject("Scripting.Dictionary")
    '行数カウント
    cnt = 0
    Open path & fname For Input As #1
    Do Until EOF(1)
        Line Input #1, buf
        cnt = cnt + 1
    Loop
    Close #1
    countLine = cnt
End Function

'ファイル探索+ファイル名変更
Sub hogeConv(path As String, ext As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String, fname As String
    Dim n As Long
    
    '処理対象ファイル探索+処理実行
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
    Set re = CreateObject("VBScript.RegExp")
    pat = "\." & ext & "$"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        For Each flist In fcol
            fname = GetFNameFromFStr(flist.name)
            Set remat = .Execute(flist.name)
            If remat.Count > 0 Then
                n = countLine(path, flist.name)
                Name path & fname & "." & ext As path & fname & "_" & n & "." & ext
            End If
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call hogeConv("C:/test/", "txt")
End Sub

他3件のコメントを見る
id:oil999

56行目を以下のように変更してください。

                Name path & fname & "." & ext As path & fname & n & "." & ext

2012/11/10 11:32:25
id:inosisi4141

ありがとうございました
完璧です

2012/11/10 13:57:22
id:Silvanus No.2

Silvanus回答回数174ベストアンサー獲得回数672012/11/09 20:31:17

ポイント20pt

もし、処理ファイル数が1万個を超える様であれば
lngNFMaxの値を増やして下さい。

Option Base 0
Option Explicit

Sub Inoshishi1352458121()

Const lngNFMax As Long = 10000
Const strPath As String = "C:\test\"

Dim strFNList(1, lngNFMax) As String
Dim strFN As String
Dim lngCnt1 As Long
Dim lngCnt2 As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

lngCnt1 = 0
strFN = Dir(strPath & "*.txt", vbNormal)

    Do While strFN <> ""
        Workbooks.Open Filename:=strPath & strFN, Format:=5
        strFNList(0, lngCnt1) = strFN
        strFNList(1, lngCnt1) = _
          Left(strFN, Len(strFN) - 4) & "_" & _
          ActiveSheet.Cells.SpecialCells(xlLastCell).Row _
          & ".txt"
        Application.DisplayAlerts = False
        ActiveWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True
        lngCnt1 = lngCnt1 + 1
        strFN = Dir
    Loop
    For lngCnt2 = 0 To lngCnt1 - 1
        Name strPath & strFNList(0, lngCnt2) As _
          strPath & strFNList(1, lngCnt2)
    Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
他7件のコメントを見る
id:Silvanus

スミマセン。不躾ながら逆質問させていただいて宜しいでしょうか。私の
マクロは、対象となるテキストファイルを一旦ワークシートに読み込んで、
読み込まれた内容の最下セル行を検出する方法で行数をカウントしています。
お手数ですが、「1」とカウントされてしまう対象ファイル(全て!?、汗)の
内のどれでも1つで構いませんので、Excelの「ファイルを開く」メニューから
タブ区切りテキストとして読み込んでみていただけないでしょうか?
(恐らく9分9厘間違いないでしょうが)ワークシートの読み込まれた結果が
件数=行数となっているかどうかご確認いただきたく存じます。

2012/11/10 14:29:39
id:Silvanus

こちらでは動いてるんですが…(涙)。最後にひとつだけ。
ActiveSheet.Cells.SpecialCells(xlLastCell).Row _

ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row _
に変えてみていただいて、上手く行かない様であれば降参します…。
誠にスミマセン…orz。

2012/11/10 16:23:19

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません