エクセルだけで差し込み印刷(3-2)

3-2)  行指定で、book作成
　非表示、フィルタで消込ができない場合　行指定でbookを作る機能を追加

1. ファイルにしたいエクセルの行番号をシートに書き込む　
2. 書かれた値を取得
3. それを起点となるActive cellに設定　
4. ファイルを作成する

自分の知識で曖昧なのは　２　エクセル上に書かれたデータの値を取得する方法
あまりやっていないけど、検索したら簡単にでてきました。
Google で検索
http://www.tipsfound.com/vba/07001

s = Range("A1").Value　
s にセルの値を取り込むことができるらしい。

これさえ分かれば後は簡単

B2セルから値を取得
' 印刷行数の取得
  Dim buf As Long
  buf = Range("B2")
  

オフセットの関係でアクティブセルは

A2と設定 ' アクティブセルの設定
　act = "A" & buf







Ｂ２の値がない時にはその行が存在しないことを表示して　プログラム停止
book 作成を繰り返す　Do　loopを削除

３－１）は書き出し先のフォルダがある場合はフォルダごと消去して
再度作り直しにしていたけど、、　
1行づつ作成の場合は、、たぶん　その行だけのbookを作成したいかも
フォルダを消すのはやめるべきか、悩む、、

エクセルファイルはここにあります

前へ　次へ

---

Sub book作成32()

'画面のちらつきを防止する
Application.ScreenUpdating = False

'リストワークシートを選択する
Worksheets("リスト").Activate


' 印刷行数の取得
  Dim buf As Long
  buf = Range("B2")
  
' アクティブセルの設定 A + 行数となる
   act = "A" & buf
  

    'ユニークファイル番号の設定、ブックを作成するときの番号を１から順につけるために必要
    uFile = 0
    
    ' Save Directory の パス設定
    パス = ActiveWorkbook.Path '　カレントパスの取得
    SaveDir = パス & "\" & Format(Date, "yyyymmdd")
    ' カレントパス,日付のフォルダがある場合はフォルダ削除して再度作成
    If Dir(SaveDir, vbDirectory) <> "" Then
        Dim FSO As Object
         Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.DeleteFolder SaveDir
        Set FSO = Nothing
        MkDir SaveDir
    Else
        MkDir SaveDir
    End If
   
   
   'リストワークシートのセルをアクティブセルにする
   Range(act).Select


   '空欄であれば、プログラムを終了する
   'Trim関数は前後のスペースを消去する
   If Trim(ActiveCell.Value) = "" Then
       MsgBox "その行は存在しません"
       End
   End If


   '非表示セルは対象としない
   If ActiveCell.EntireRow.Hidden = False Then

      'Format1 シートにリストの内容を繁栄される
       With Worksheets("Format1")

       'レコードの先頭セルを選択
       'Format1 D10に リストの　A7の内容を移動
         .Range("D10").Value = ActiveCell.Offset(0, 0).Value
        'Format1 D12に リストのA7から指定セルを移動するために　上下方向0, 右方向に１移動
         .Range("D12").Value = ActiveCell.Offset(0, 1).Value
         .Range("F12").Value = ActiveCell.Offset(0, 2).Value
         
       'レコードの最終セルであれば、Format１シートをsaveする
           Sheets("Format1").Select 'シートをアクティブにする
          ' ユニークファイル番号の設定
          uFile = uFile + 1
          
          '名前重複排除　別名を作成　フォーマットは　1-D12-F12.xls とする
          別名 = SaveDir & "\" & uFile & "-" & Range("D12") & "-" & Range("F12") & ".xls" 'パスと拡張子を付ける
          Sheets("Format1").Copy 'シートを新規ブックへコピー ※１
          'ActiveWorkbook.SaveAs Filename:=別名, FileFormat:=xlWorkbookDefault  '別名を付けてブックを保存する
          ActiveWorkbook.SaveAs Filename:=別名, FileFormat:=XlFileFormat.xlExcel8
          ActiveWorkbook.Close '別名ブックを閉じる
          
          Sheets("リスト").Select  ' リストシートをアクティブにする
       
          End With

    End If



End Sub