エクセルだけで差し込み印刷(5)

今まで書いてきた簡単なマクロさらに機能を追加する必要がでてきました。
いままでは１つの行の情報を１つの申請書に埋ていくマクロだったのですが
今度は　例えば　２０行の情報を　１枚の申請書にまとめます。
こんなのは別に　元の情報を成形して印刷すれば終わりと考えていたのですが、
作りました。
理由は仕事の簡略化です、１つのエクセルの情報を更新、その更新した情報からの
印刷にすれば、エクセルを更新しないというミスを防ぐことができます。
とにかく１つのエクセルを起点にしてミスを防ぐための準備です。


燃やじいも書いたことないので、簡単にできるか判断は付かなかったので
ちょこちょこ調べた。　ほかのプログラムの経験から
不足してるマクロの情報は下記

• 配列変数の扱い
• 宣言
• 呼び出しかた
• 配列変数の中の変数の個数の確認方法
• ひな型に埋めるときのセルの場所の指定方法
  今までのやり方だと　　
  アクティブセルを起点に　そこから　移動させ取得した値を　Rangeで　選択した
  セルに表示させる方法をとっていた
  　　　A7をアクティブセルにして　　　　　
  　　　Format1シートのD10に リストの　A7の内容を移動
  　　　.Range("D10").Value = ActiveCell.Offset(0, 0).Value
  この方法だと　複数のレコードを　Format1シートのどのセルに
  書き込ませるか指定する方法が分からなかった。
CELLの指定方法はセルの名前　例えば　A1　などの代わりに　
A1の指定は　Cells(1,1)  （行数、列番号）　の順番で指定できるとこがわかり
それぞれの値は数字だけでなく式を直接書き込んでも問題ないことを確認した。

もう書けるじゃん、これだけ分かれば、、、


ほんとはね、アシスタントがいなくなり、書類を全部自分で片づけなければ
ならなくなりました。
アシスタントのやっていたことを自分でやることになるんだけど、いろいろ自分でやっていて、
気づくことが多数、　エクセルだけで差し込み印刷　する方法教えたのだけど、、　
応用はされていなくて、
指示したことはやってくれてたんだ、と少し残念な気分になってきた。

アシスタントにも思いつくのではないかと思うけど、律儀に、、、一枚づつ手動でコピペ。。。
こういった機能のプログラムを書いたことがない人は考えるだろうな。
書けるか書けないか、あてもないことをするなら、コピペ。
何十回も、コピペしてきたと思うと悲しくなる。
確認に2時間もかかったけど、プログラムが成形して印刷してくれる、コピペは人をダメにするけど
マクロを書いた人は自分が成長する。

私は満足。。　　なのかぁあ

いろいろな仕事があるのだけど、、
過去からのしがらみ、仕事できない経理のおかげで固定資産の管理がめちゃくちゃ
資産管理簿＝エクセルのブック　
使用場所が変わると納税先が変わる、そんな時は異動届
貸出ユーザが変わる場合は、貸出し受領確認書
捨てる時は廃棄届

これが全部別のエクセルbookになっていて、、、　
エクセルはただの書式を作成するものになっていて、それをサインのために回す
だけで、エクセルで情報を管理するという考えがない会社のようだった。

異動届は出し忘れが見つかった、アシスタントが管理していた時に移動したものだった。。

たった３つの書類が必要なんだけど
これが全部別のエクセルbookになっている。
そう　３つの書類に必要なすべての情報は資産管理簿というエクセルの中にある
情報なんだけど、気づかない。
変更があるたび、ひな型を埋めて、印刷してサインを回して、、、
でも、このやり方を教えてあるのに応用ができていない。。。
なんでだろう。　　言われることをすればできる人なのになんで、、、
すべて指示しないとできないのか。。。
これ、課題だなぁ。　気づいてもらいたいんだけど。。。　なんで気づかないのか？？
個人への貸出受領確認書は１レコードの情報を１枚のシートに埋めるだけでよいので
分かりやすい応用。。
ほかの　２つは、今回書いた、複数レコードをまとめて１枚の申請書に書き換えるので
できないとあきらめていたのかも、、

燃やじいも書いたことないので、簡単にできるか判断は付かなかったので
ちょこちょこ調べた。

アシスタントにも思いつくのではないかと思うけど、律儀に、、、一枚づつ手動でコピペ。。。


前へ　マクロは今度ね

エクセルだけで差し込み印刷（4) 機能追加

エクセルだけで差し込み印刷（4)　機能追加をしました。

3-1 で　作成するブックが多いとエクセルが固まったように見えるので
1)実行時に何件あるのか表示確認
2)ステータスを更新する
3)マクロ終了時に作成フォルダを開く

これらの機能をインターネットで検索してマクロに追加しました。
それぞれの機能に必要なコマンドを調べました。

1) フィルタされて表示されている行数のみをカウントする。
これ、なかなか見つけるのが大変でした。
意味不明でした。　分解します


Ｒａｎｇｅ（）.Count,Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible)
XCellTypeVisivle ：　見えているものだけカウントする
_複数の行を１行としてあつかう、意味不明でわからなかったのですが
一行が長くなる時に分けるセパレータでした。　一行ならなくても可能

 ' 行数カウント
    cnt =Range(Range("A6"), Cells(Rows.Count, 1).End(xlUp))
_SpecialCells(xlCellTypeVisible).Count

             
　列の下から数えてA6まで、値が入っているの行数を調べる

    ' A6からのカウントなので　１行引く
    cntL = cnt - 1


   '実行確認メッセージ
    If MsgBox("件数" & cntL & "件、実行しますか？ ", vbYesNo) = vbNo Then
        End
    End If

2) ステータスの更新
これは簡単に見つかった、　左下に何件シートを処理しているか表示します
　 ' ステータスバーに書き込む
          Application.StatusBar = "処理実行中．．．．(現在 " & uFile & "件)"


　　放置すると　最後の件数が表示されっぱなしになるので消去
　　　'ステータスバーの消去
 　　　　Application.StatusBar = False

3) マクロ終了時フォルダを開く
　　　
'使用したフォルダを開く
CreateObject("Shell.Application").Open SaveDir

マクロファイルはこちら

前へ　次へ




---------------------------------

Sub book作成35()

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

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

'リストワークシートのセルA6をアクティブセルにする
Range("A6").Select

  ' 行数カウント
    cnt = Range(Range("A6"), Cells(Rows.Count, 1).End(xlUp)) _
                .SpecialCells(xlCellTypeVisible).Count
             
    ' A6からのカウントなので　１行引く
    cntL = cnt - 1


   '実行確認メッセージ
    If MsgBox("件数" & cntL & "件、実行しますか？ ", vbYesNo) = vbNo Then
        End
    End If


    'ユニークファイル番号の設定、ブックを作成するときの番号を１から順につけるために必要
    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
 
   'ループの開始
   Do
   'アクティブセルを１つ下に移動する　A7になる
   ActiveCell.Offset(1, 0).Select

   '空欄であれば、プログラムを終了する
   'Trim関数は前後のスペースを消去する
   If Trim(ActiveCell.Value) = "" Then
      Exit Do
   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:=XlFileFormat.xlExcel8   '別名を付けてブックを保存する
          ActiveWorkbook.Close '別名ブックを閉じる
       
          Sheets("リスト").Select  ' リストシートをアクティブにする
          ' ステータスバーに書き込む
          Application.StatusBar = "処理実行中．．．．(現在 " & uFile & "件)"
          End With

    End If

   'ループの終了
   Loop

'ステータスバーの消去
 Application.StatusBar = False
'使用したフォルダを開く
CreateObject("Shell.Application").Open SaveDir

End Sub

エクセルだけで差し込み印刷

既存エクセルファイルから、住所などをフォーマットにしたがって

Bookや印刷するためのマクロです。

カスタマイズできるように、複雑にするのはやめて

簡単に使えるようにした。

非効率なことをしていたのでつくりました。
しもじもの者がリクエストを書くのに、エクセルに日付、名前、項目などを書きその情報を、それをエクセルで作られた指定フォーマットにコピペして印刷
承認者に紙を回して承認。

おじいさんとしてはあり得ないことを強いていると思いました。

これはいかん、おじいさんは立ち上がったのでした。ボーボーっ

しかも、この機能、簡単なのにネットでカスタマイズして販売している人もいて
驚き、、、　印刷フォーマットに合わせて変更が簡単なマクロを作ろうと思いました。
リストからの単票印刷と言うらしい。
自分でマクロを修正できるといろいろ便利です。
例えば、エクセルのレコードに、物品の登録、移動、廃棄の情報を入れて
別のシートにそれぞれフォーマットを用意、人間の承認などのシートを印刷して
人間の管理ように使うようにすれば。
起点がエクセルシート一つになるので、取りこぼしがなくなります。
エクセルをエディットしなければ、シートが印刷できない流れにしてしまえばいいのです。
そうすれば情報の更新を忘れたりしません。
雑多なものの管理は一方通行が一番です。

普通だと　エクセルにあるデータをワードに貼り紙込み印刷するのが差し込み印刷機能ですが

エクセルのデータを変更したりすると、ワードで更新とか。　ワードがどこかに行ってしまったり

エクセルのデータが移動とか消されたり

会社だとめんどくさい。

のでエクセルのブック１つですべて賄ってしまおうと準備しました。

ここでも書きましたが、会社でありがちな、申請書、封筒や、はがきの印刷にも
カスタマイズして使えるようにマクロを書きました。

見た目はしたのように　
左　リストシートにある情報を右　Format1に順次埋め込み　bookを作成する
Ｆｏｒｍａｔ１は好きに変更可能 リストの内容も好きに変更可能

タダです使ってください。

やることは

1)　データを作る　

2)　データを埋め込むフォーマット作成

3)　マクロを書く

　　3-1) 表示されているレコードをフォーマットに埋め込みレコード毎にbookを作成

　　　　フィルターで見えないものはBookを作りません

　　3-2)  行指定で、book作成

　　3-3)  フィルタかけて表示されているものを印刷

　　3-4)  行指定　印刷

簡単便利　で　会社で拡散中、してないか？

貸与品情報のシートから貸し出し申請を印刷サインを取得とか

物品購入など繰り返し使うものに応用すると

日付、物品、金額を書き込みフォーマットに嵌め込み印刷して

申請。　間違えが減るし、副作用として購入申請したものは

すべてエクセルに残るので全部集計するのも楽に❗

次へ

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

3-4)  行指定　印刷

これは　3-2　で作った行指定book作成と　3-3　で作った印刷の応用

3-2で作った行指定book　をコピーして
印刷指定行Ｂ４に変更
book作成部分を　Ｐｒｉｎｔに変更

マクロファイルはこちら

前へ 次へ
---

Sub book作成34()

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

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


' 印刷行数の取得
  Dim buf As Long
  buf = Range("B4")

' アクティブセルの設定 A + B4で書き込んだ行数とする
   act = "A" & buf

 
    ' 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
         
         .PrintOut
          Sheets("リスト").Select  ' リストシートをアクティブにする
     
        End With

    End If


End Sub

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

さて、bookをつくるから、印刷に変更

3-1) のbookを作る機能を印刷に変更するだけだと推測はしていますが
印刷コマンドがわからん。

早速　エクセルマクロ　印刷　で　検索しました。

.PrintOut

これだけで　ＯＫのような、、

で作ったのがしたのマクロ　一発で動きました。

きもちいいー

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

前へ　次へ

---

Sub book作成33()

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

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

'リストワークシートのセルA6をアクティブセルにする
Range("A6").Select
  

    'ユニークファイル番号の設定、ブックを作成するときの番号を１から順につけるために必要
    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
   
   'ループの開始
   Do
   'アクティブセルを１つ下に移動する　A7になる
   ActiveCell.Offset(1, 0).Select

   '空欄であれば、プログラムを終了する
   'Trim関数は前後のスペースを消去する
   If Trim(ActiveCell.Value) = "" Then
      Exit Do
   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
         
          .PrintOut
          Sheets("リスト").Select  ' リストシートをアクティブにする
          End With

      End If

   'ループの終了
   Loop

End Sub

エクセルだけで差し込み印刷(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

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

エレガントなコードは書けないけど、仕事が簡単になればいいじゃないか？早く、自分にもどろう。

　3-1) 表示されているレコードをフォーマットに埋め込みレコード毎にbookを作成

　　　見えないものはBookを作りません、なのでbookを作りたくないときが非表示にするかフィルタを使ってください。
　　　　

エクセルのデータはリストシートに書く。

Ａ６から書き始める。　このセルを起点に使いマクロを動かす

６行目に書くのは項目、自由に変更可能

ひな形は　Format1　に作成　（　見た目なので好きに変更可能　）

リストシートの日付を　Ｆｏｒｍａｔ１のD10,D15,F15 Ｃｅｌｌに書き込んで　そのbookを 日付フォルダの中に作成します。　

カスタマイズするのに必要な知識はマクロの中のこの部分のみ

       '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

アクティブセル（エクセルで選択したセル）の内容をFormat1に書込む
起点となる　アクティブセルに対してどれだけ動かすか指定するのが
　　　　ActiveCell.Offset(0, 0)　：　　オフセットの指定は（上下、左右）　

動かしてみてください。Formatはあなたの美的センスでなんとでもなるでしょう。

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

リリースして気が付いた、印刷機能がないですね。　book作成機能が欲しかったので
先に作っちゃいました。　印刷はたぶん簡単だと思う。


前へ  次へ

---

Sub book作成()

'画面のちらつきを防止する

Application.ScreenUpdating = False

'リストワークシートを選択する

Worksheets("リスト").Activate

'リストワークシートのセルB6をアクティブセルにする

Range("A6").Select

  

    'ユニークファイル番号の設定、ブックを作成するときの番号を１から順につけるために必要

    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

   

   'ループの開始

   Do

   'アクティブセルを１つ下に移動する　A7になる

   ActiveCell.Offset(1, 0).Select

   '空欄であれば、プログラムを終了する

   'Trim関数は前後のスペースを消去する

   If Trim(ActiveCell.Value) = "" Then

      Exit Do

   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:=XlFileFormat.xlExcel8   '別名を付けてブックを保存する

          ActiveWorkbook.Close '別名ブックを閉じる

          

          Sheets("リスト").Select  ' リストシートをアクティブにする

       

          End With

    End If

   'ループの終了

   Loop

End Sub