| |
雛型の元となるBookが開かれて居ても、居なくても使用出来ます
出力は、雛型の元となるBookと同じフォルダとします
現状のコードでは、データのあるBook、SheetはActiveWorkbookのActiveSheetとしています
因って、マクロの開始は、データListのシートの上で実行して下さい
以下のコードを標準モジュールに記述して下さい
Option Explicit
Public Sub CreateModel()
'データの列数
Const clngCoiumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim wkbModel As Workbook
Dim vntTempFile As Variant
Dim strPath As String
Dim rngList As Range
Dim strOutFile As String
Dim objFso As Object
Dim blnSkip As Boolean
Dim strProm As String
'データの有るシートのA1を基準として指定（実状に合わせて変更）
Set rngList = ActiveWorkbook.ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'Offset値とする為-1
lngRows = lngRows - 1
End With
'雛型の元となるBookを指定
strPath = ThisWorkbook.Path
'雛型の元となるBookが常に同じなら拡張子を取り払った名前を指定してもOk
' vntTempFile = "VBA*"
If Not GetReadFile(vntTempFile, strPath, False) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'FSOオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'雛型の元となるBookのパスを取得（出力されるBookのパスとする）
strPath = objFso.GetParentFolderName(vntTempFile)
'雛型の元となるBookをOpen
If Not BookOpen(vntTempFile, wkbModel, objFso) Then
strProm = "指定されたBookが無いので終了します"
GoTo Wayout
End If
Application.ScreenUpdating = False
'データ全てに就いて繰り返し
For i = 0 To lngRows
'出力Bookの名前を取得、及び妥当性確認
strOutFile = NameLetter(rngList.Offset(i).Text)
'出力Bookの存在確認と、存在した場合の枝番付加
If Not FileNameCheck(strOutFile, strPath, objFso) Then
If MsgBox("既に同名のBookが存在しますので" & vbCrLf _
& strOutFile & "で保存します いいえ = Skip", _
vbInformation + vbYesNo, _
"Book名の重複") = vbNo Then
blnSkip = True
End If
End If
If Not blnSkip Then
'データの転記
rngList.Offset(i).Resize(, clngCoiumns).Copy _
Destination:=wkbModel.Worksheets(1).Cells(1, "A")
'Bookの保存
wkbModel.SaveAs FileName:=strOutFile
End If
Next i
'雛型の元となるBookをClose
wkbModel.Close
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set objFso = Nothing
Set rngList = Nothing
Set wkbModel = Nothing
Beep
MsgBox strProm
End Sub
Private Function BookOpen(ByVal strFileName As String, _
wkbMark As Workbook, _
objFso As Object) As Boolean
' 指定されたBookをOpen
Dim strExten As String
Dim strName As String
Dim blnExist As Boolean
With objFso
strExten = .GetExtensionName(strFileName)
strName = .GetFileName(strFileName)
End With
If objFso.FileExists(strFileName) Then
If strExten = "xls" Then
For Each wkbMark In Workbooks
With wkbMark
If StrComp(.Name, strName, vbTextCompare) = 0 Then
blnExist = True
Exit For
End If
End With
Next wkbMark
If Not blnExist Then
Set wkbMark = Workbooks.Open(strFileName)
Else
wkbMark.Activate
End If
BookOpen = True
End If
End If
End Function
Private Function NameLetter(ByVal strName As String) As String
' File名のチェック
Dim i As Long
Dim vntLetter As Variant
Dim lngPos As Long
'シート名として使用不可能な文字の一覧を作成
vntLetter = Array(":", "\", "?", "[", "]", "/", "*")
'一覧全てに就いて
For i = 0 To UBound(vntLetter, 1)
'引数の文字列に一覧の文字が含まれるか探索
lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
'引数の文字列に一覧の文字が無くなるまで繰り返し
Do Until lngPos = 0
'有る場合、"_"に置換
strName = Left(strName, lngPos - 1) _
& "_" & Mid(strName, lngPos + 1)
'引数の文字列に一覧の文字が含まれるか探索
lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
Loop
Next i
'戻り値として、置換後の文字列を返す
NameLetter = strName
End Function
Private Function FileNameCheck(strName As String, _
strFilePath As String, _
objFso As Object, _
Optional strExte As String = ".xls") As Boolean
' 同一Faile名の存在確認と枝番付加
Dim i As Long
Dim strTmpName As String
i = 1
strTmpName = strName
Do Until Not objFso.FileExists(strFilePath & "\" & strTmpName & strExte)
i = i + 1
strTmpName = strName & "(" & i & ")"
Loop
If i > 1 Then
'"()"で括った枝番を付与して返す
strName = strFilePath & "\" & strName & "(" & i & ")" & strExte
Else
strName = strFilePath & "\" & strName & strExte
FileNameCheck = True
End If
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/8/7(日) 18:41 -
