質問です。

c:\test\の中に複数のtxtファイルがあります。ファイル名の最初に01-aaaa.txtみたいに2桁の数字(数字は01から99)とハイフォンが半角でついています、この01-の3桁を削除してaaaa.txtで保存するマクロはできますか

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/12/12 18:23:21
  • 終了:2011/12/12 19:52:52

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/12/12 18:47:53

ポイント30pt
Public w As Workbook
Public 読み込み数 As Long
Public カラム数 As Integer

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "txt")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim gg As Long
Application.DisplayAlerts = False

Dim fdb() As String
    
a = 1
f = Dir(p & "*." & s, vbNormal)
Do While f <> ""
    ReDim Preserve fdb(a)
    fdb(a - 1) = f
    a = a + 1
    f = Dir
Loop


For aaa = 0 To a - 2
    f = fdb(aaa)
    f1 = Left(f, Len(f) - 4)

    csvImp (p & f)
    w.Sheets(1).Rows(1).Delete Shift:=xlUp
    読み込み数 = 読み込み数 - 1
    
    
    Call WRITE_CSVFile(p & f & "wrk")
    w.Close
    Kill p & f
    Name p & f & "wrk" As p & f

    ck = Left(f, 2)
    If Val(ck) >= 1 And Val(ck) <= 99 Then
        If Mid(f, 3, 1) = "-" Then
            b = Len(f) - 3
            Name p & f As p & Right(f, b)
        End If
    End If

Next aaa

Application.DisplayAlerts = True

End Sub


Sub csvImp(csFName As String)

Const csDelimiter As String = ","

Dim FNo As Integer

Dim wsObj As Worksheet

Dim strGet As String

Dim lRowCnt As Long

Dim i As Long

FNo = FreeFile

If Dir(csFName) <> "" Then

    Open csFName For Input As #FNo
    Set w = Workbooks.Open(Filename:=csFName, UpdateLinks:=False, ReadOnly:=False)
    
    Set wsObj = Workbooks(w.Name).Sheets(1)
    lRowCnt = 1
    カラム数 = 0
    Do Until EOF(FNo)
    
        Line Input #FNo, strGet
        
        For i = LBound(Split(strGet, csDelimiter)) To UBound(Split(strGet, csDelimiter))
        
            If IsNumeric(Split(strGet, csDelimiter)(i)) = True And Left(Split(strGet, csDelimiter)(i), 1) = "0" Then
            
               wsObj.Cells(lRowCnt, i + 1).NumberFormatLocal = "@"
            
            End If
            
            wsObj.Cells(lRowCnt, i + 1) = Split(strGet, csDelimiter)(i)
    
        Next i
        
        lRowCnt = lRowCnt + 1
        If カラム数 < i Then カラム数 = i
    Loop
    
    
    Close #FNo
読み込み数 = lRowCnt - 1
End If

End Sub

Sub WRITE_CSVFile(pa As String)
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim strREC As String
    Dim FNo As Integer
    
    Dim lRowCnt As Long
    
    FNo = FreeFile
           
    ' 指定ファイルをOPEN(出力モード)
    Open pa For Output As #FNo

    ' 最終行の取得
    With w.Sheets(1)
        GYO = 1
        ' 最終行まで繰り返す
        Do Until GYO > 読み込み数
            ' レコードを出力(REC編集処理より受取る)
            strREC = .Cells(GYO, 1).Value
            For COL = 2 To カラム数
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
    

End Sub

1行目削除とセットにしました。

id:inosisi4141

ありがとうございます。
今度は上手く行きました1行目セットで助かります。

2011/12/12 19:47:49

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/12/12 18:38:19

ポイント10pt

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "txt")

End Sub


Sub jikkou(p As String, s As String)

Application.DisplayAlerts = False

Dim fdb() As String
    
a = 1
f = Dir(p & "*." & s, vbNormal)
Do While f <> ""
    ReDim Preserve fdb(a)
    fdb(a - 1) = f
    a = a + 1
    f = Dir
Loop


For aaa = 0 To a - 2
    f = fdb(aaa)
    a = Left(f, 2)
    If Val(a) >= 1 And Val(a) <= 99 Then
        If Mid(f, 3, 1) = "-" Then
            b = Len(f) - 3
            Name p & f As p & Right(f, b)
        End If
    
    End If
Next aaa

Application.DisplayAlerts = True

End Sub


id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/12/12 18:47:53ここでベストアンサー

ポイント30pt
Public w As Workbook
Public 読み込み数 As Long
Public カラム数 As Integer

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "txt")

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim gg As Long
Application.DisplayAlerts = False

Dim fdb() As String
    
a = 1
f = Dir(p & "*." & s, vbNormal)
Do While f <> ""
    ReDim Preserve fdb(a)
    fdb(a - 1) = f
    a = a + 1
    f = Dir
Loop


For aaa = 0 To a - 2
    f = fdb(aaa)
    f1 = Left(f, Len(f) - 4)

    csvImp (p & f)
    w.Sheets(1).Rows(1).Delete Shift:=xlUp
    読み込み数 = 読み込み数 - 1
    
    
    Call WRITE_CSVFile(p & f & "wrk")
    w.Close
    Kill p & f
    Name p & f & "wrk" As p & f

    ck = Left(f, 2)
    If Val(ck) >= 1 And Val(ck) <= 99 Then
        If Mid(f, 3, 1) = "-" Then
            b = Len(f) - 3
            Name p & f As p & Right(f, b)
        End If
    End If

Next aaa

Application.DisplayAlerts = True

End Sub


Sub csvImp(csFName As String)

Const csDelimiter As String = ","

Dim FNo As Integer

Dim wsObj As Worksheet

Dim strGet As String

Dim lRowCnt As Long

Dim i As Long

FNo = FreeFile

If Dir(csFName) <> "" Then

    Open csFName For Input As #FNo
    Set w = Workbooks.Open(Filename:=csFName, UpdateLinks:=False, ReadOnly:=False)
    
    Set wsObj = Workbooks(w.Name).Sheets(1)
    lRowCnt = 1
    カラム数 = 0
    Do Until EOF(FNo)
    
        Line Input #FNo, strGet
        
        For i = LBound(Split(strGet, csDelimiter)) To UBound(Split(strGet, csDelimiter))
        
            If IsNumeric(Split(strGet, csDelimiter)(i)) = True And Left(Split(strGet, csDelimiter)(i), 1) = "0" Then
            
               wsObj.Cells(lRowCnt, i + 1).NumberFormatLocal = "@"
            
            End If
            
            wsObj.Cells(lRowCnt, i + 1) = Split(strGet, csDelimiter)(i)
    
        Next i
        
        lRowCnt = lRowCnt + 1
        If カラム数 < i Then カラム数 = i
    Loop
    
    
    Close #FNo
読み込み数 = lRowCnt - 1
End If

End Sub

Sub WRITE_CSVFile(pa As String)
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim strREC As String
    Dim FNo As Integer
    
    Dim lRowCnt As Long
    
    FNo = FreeFile
           
    ' 指定ファイルをOPEN(出力モード)
    Open pa For Output As #FNo

    ' 最終行の取得
    With w.Sheets(1)
        GYO = 1
        ' 最終行まで繰り返す
        Do Until GYO > 読み込み数
            ' レコードを出力(REC編集処理より受取る)
            strREC = .Cells(GYO, 1).Value
            For COL = 2 To カラム数
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
    

End Sub

1行目削除とセットにしました。

id:inosisi4141

ありがとうございます。
今度は上手く行きました1行目セットで助かります。

2011/12/12 19:47:49
id:kodairabase No.3

kodairabase回答回数661ベストアンサー獲得回数802011/12/12 18:49:02

ポイント60pt

先頭1行削除を組み込んであります。
また、ご質問のファイル名以外は、そのまま残すようにしてあります。

Option Explicit

Sub delTopLineSub(path As String, fname As String)
    Dim buf As String
    Dim fname1 As String, fname2 As String
    fname1 = path & fname
    fname2 = path & fname & ".$$$"
    Open fname1 For Input As #1
    Open fname2 For Output As #2
    Line Input #1, buf   '1行目読み飛ばし
    Do Until EOF(1)
       Line Input #1, buf
       Print #2, buf
    Loop
    Close #1
    Close #2
    Kill fname1
    Name fname2 As fname1
End Sub

Sub hogeRename(path As String, ext As String, pat As String)
    Dim fname As String
    Dim re As Object, mat As Object

    fname = Dir(path & "*." & ext, vbNormal)
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        Do While fname <> ""
            Set mat = .Execute(fname)
            If mat.Count > 0 Then
                Call delTopLineSub(path, fname)
                Name path & fname As path & re.Replace(fname, "")
            End If
        fname = Dir()
    Loop
    End With
    Set mat = Nothing
    Set re = Nothing
End Sub

Sub main()
    Call hogeRename("C:\test\", "txt", "^[0-9]{2}\-")
End Sub
id:inosisi4141

ありがとうございます
1行目削除とセットで助かりました。

2011/12/12 19:51:01
  • id:inosisi4141
    できれば01-aaaa.txtで頭3桁を削除してaaaa.txtで保存するときに前回のtxtファイルの1行目を削除するマクロも同時に行えるとよいのですが

    ファイル名
    01-aaaa.txt
    データ
    1行目項目
    abcd

    答え
    ファイル名
    aaaa.txt
    データ
    abcd
  • id:inosisi4141
    項目の属性はA列とG列に090*******とあたまに0がつく数字がありますので0が取れないように保存できるようにする
  • id:kodairabase
    先頭1行削除を組み込みました。

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

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

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

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