Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


54149 / 76732 ←次へ | 前へ→

【27383】Re:繰り返し処理で名をつけてファイル保存
回答  Hirofumi  - 05/8/7(日) 21:57 -

引用なし
パスワード
   雛型の元となる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
1 hits

【27381】繰り返し処理で名をつけてファイル保存 apple 05/8/7(日) 18:41 質問
【27382】Re:繰り返し処理で名をつけてファイル保存 かみちゃん 05/8/7(日) 19:18 回答
【27385】Re:繰り返し処理で名をつけてファイル保存 apple 05/8/7(日) 22:07 お礼
【27383】Re:繰り返し処理で名をつけてファイル保存 Hirofumi 05/8/7(日) 21:57 回答
【27384】Re:繰り返し処理で名をつけてファイル保存 apple 05/8/7(日) 22:05 お礼
【27386】Re:繰り返し処理で名をつけてファイル保存 Hirofumi 05/8/7(日) 22:13 回答
【27387】Re:繰り返し処理で名をつけてファイル保存 apple 05/8/7(日) 22:19 お礼

54149 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free