2016年6月18日土曜日

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

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

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

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

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


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

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

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

    ' A6からのカウントなので 1行引く
    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からのカウントなので 1行引く
    cntL = cnt - 1


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


    'ユニークファイル番号の設定、ブックを作成するときの番号を1から順につけるために必要
    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
   'アクティブセルを1つ下に移動する 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, 右方向に1移動
         .Range("D12").Value = ActiveCell.Offset(0, 1).Value
         .Range("F12").Value = ActiveCell.Offset(0, 2).Value
       
       'レコードの最終セルであれば、Format1シートをsaveする
           Sheets("Format1").Select 'シートをアクティブにする
          ' ユニークファイル番号の設定
          uFile = uFile + 1
       
          '名前重複排除 別名を作成 フォーマットは 1-D12-F12.xls とする
          別名 = SaveDir & "\" & uFile & "-" & Range("D12") & "-" & Range("F12") & ".xls" 'パスと拡張子を付ける
          Sheets("Format1").Copy 'シートを新規ブックへコピー ※1
          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

0 件のコメント:

コメントを投稿

注目の投稿

ブラザー刺繍ミシン USBがついたら、、、

以前つかっていたのは イノビス α80 データは刺繍カードを購入したり、ハートスティッチーズDLでデータを作っていた。 両方とも専用のUSBカードにデータをミシンに入れて刺繍できていた。 新しいFE1000を購入問題発生 がっかりポイント多数 ハートスティッチーズ...