人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●10ポイント

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



2 ● きゃづみぃ
●30ポイント ベストアンサー
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行目削除とセットにしました。


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

3 ● kodairabase
●60ポイント

先頭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

inosisiさんのコメント
ありがとうございます 1行目削除とセットで助かりました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ