| |
下記マクロをxlsm形式（マクロ有効ブック）で新規保存できるようにしたいのですが、
どこをどのように変更したらよいのでしょうか？
いろいろと書き換えてみましたがうまくいかずデバックの嵐です(/_;)
めちゃめちゃ初心者ですがよろしくお願いします。
Sub 上書きマクロ()
Dim dataFolder As String
Dim tmpSheet As Worksheet
Dim subFolder As String
Dim lastRow As Long
Dim fileName As String
Dim r As Long
Dim i As Long
Dim isOpen As Boolean
Dim book As Workbook
Dim csv As Workbook
Application.ScreenUpdating = False
dataFolder = "D:\makomako"
Set tmpSheet = Sheets("Sheet1")
tmpSheet.Cells.Clear
'フォルダ名取得
r = 1
subFolder = Dir(dataFolder & "\", vbDirectory)
Do While subFolder <> ""
If (GetAttr(dataFolder & "\" & subFolder) And vbDirectory) = vbDirectory Then
If subFolder <> "." And subFolder <> ".." Then
tmpSheet.Range("A" & r) = subFolder
r = r + 1 '出力行+1
End If
End If
subFolder = Dir
Loop
'csvファイル名取得
lastRow = tmpSheet.Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To lastRow
fileName = Dir(dataFolder & "\" & tmpSheet.Range("A" & i).Value & "\*.csv")
Do While fileName <> ""
tmpSheet.Range("B" & r) = Left(fileName, InStrRev(fileName, ".") - 1)
tmpSheet.Range("C" & r) = tmpSheet.Range("A" & i).Value
r = r + 1
fileName = Dir
Loop
Next
'ファイル名、フォルダ名で並べ替え
tmpSheet.Columns("B:C").Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=tmpSheet.Range("C1"), Order2:=xlAscending, Header:=xlNo
'bookへcsvファイルを集計
lastRow = tmpSheet.Range("B" & Rows.Count).End(xlUp).Row
isOpen = False
For r = 1 To lastRow
fileName = dataFolder & "\" & tmpSheet.Range("C" & r).Value & "\" & tmpSheet.Range("B" & r).Value & ".csv"
Set csv = Workbooks.Open(fileName)
If Not isOpen Then
csv.Sheets(1).Copy
Set book = ActiveWorkbook
isOpen = True
Else
csv.Sheets(1).Copy After:=book.Sheets(book.Sheets.Count)
End If
book.Sheets(book.Sheets.Count).Name = tmpSheet.Range("C" & r).Value
csv.Close False
If tmpSheet.Range("B" & r).Value <> tmpSheet.Range("B" & r + 1).Value Then
book.SaveAs dataFolder & "\" & tmpSheet.Range("B" & r).Value
book.Close False
isOpen = False
End If
Next
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
