Excel VBA質問箱 IV

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

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


9437 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【27381】繰り返し処理で名をつけてファイル保存
質問  apple E-MAIL  - 05/8/7(日) 18:41 -

引用なし
パスワード
   助けてください。元データのファイルから順番に一行ずつコピーし、雛型の別ファイルへそのデータをペイスト。で、そのファイルを名前をA列にある名称で保存していく、というのを繰り返すというもの。

   A    B    C    D  .......

1 apple  pie   \500

2 banana  cake  \480

3 berries tart  \550

.
.
.
.
.

と元データがあったとしてこれを上から一行のみ順番に 例(A,1:D1)をコピーし、別ファイルの雛形ファイルの同じ場所へペイストする。そして、そのファイルをA1の"apple"という名で保存する。次に、(A,2:D,2)という様に。

これはどうしたらいいでしょうか?
for next で作ってみたんですが、それは、雛型のほうのセルにvlook-upを入れたものなので希望のもので無く。
力を貸してください! 
thaliarynn@hotmail.com

【27382】Re:繰り返し処理で名をつけてファイル保存
回答  かみちゃん  - 05/8/7(日) 19:18 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>元データのファイルから順番に一行ずつコピーし、雛型の別ファイルへそのデー
>タをペイスト。で、そのファイルを名前をA列にある名称で保存していく、とい
>うのを繰り返すというもの。

「マクロの記録」である程度まではできます。
そして、For 〜 Next で繰り返し処理を加えると、こんな感じになります。
Option Explicit
Sub Macro1()
 Dim Wb2 As Workbook
 Dim LastRowNo As Long
 Dim RowNo As Long
 
 '雛形ブックを指定(あらかじめオープンしておく)
 Set Wb2 = Workbooks("Test0807_2.xls")
 
 'A列の最終列を取得
 LastRowNo = Range("A65536").End(xlUp).Row
 For RowNo = 1 To LastRowNo
  If Range("A" & RowNo).Value <> "" Then
   'A1:D1を雛形ブックのSheet1のA1セルにコピーする。
   Range("A" & RowNo & ":D" & RowNo).Copy Destination:=Wb2.Sheets("Sheet1").Range("A1")
   '雛形ブックのSheet1のA1セルの名前で保存する。
   '保存先フォルダは、このマクロブック(ThisWorkbook)と同じフォルダ
   Wb2.SaveAs Filename:= _
      ThisWorkbook.Path & "\" & Wb2.Sheets("Sheet1").Range("A1").Value & ".xls"
  End If
 Next
 Set Wb2 = Nothing
 MsgBox "終了しました。"
End Sub

【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

【27384】Re:繰り返し処理で名をつけてファイル保存
お礼  apple E-MAIL  - 05/8/7(日) 22:05 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございます。明日、会社でやってみます。
また、何かありましたら、力を貸してくださいね。

【27385】Re:繰り返し処理で名をつけてファイル保存
お礼  apple E-MAIL  - 05/8/7(日) 22:07 -

引用なし
パスワード
   かみちゃん
ありがとうございます。会社で、これ組んでみたいとおもいます。
また、何かありましたら教えてくださいね。

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

引用なし
パスワード
   ゴメン、プロシージャが一つ抜けってた
以下のコードを前のコードと同一の標準モジュールに追加して下さい


Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  Dim strTitle As String
  
  'タイトルを作成
  strTitle = "雛型の元となるBookを選択して下さい"
  'フィルタ文字列を作成
  strFilter = "Excel File (*.xls),*.xls," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, _
                  strTitle, , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【27387】Re:繰り返し処理で名をつけてファイル保存
お礼  apple E-MAIL  - 05/8/7(日) 22:19 -

引用なし
パスワード
   なんてやさしい!すごく感動してます。
ありがとうございます!

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