「マクロで壁に・・・」で悪戦苦闘していたマクロのほぼ実用段階のプロトタイプがやっと出来上がりました。「図1」や「図２」のような感じで窓の配置をシートに作ってメーカーにFAXをするのですが、これ以外にも窓の大きさや形に種類があるのです。
前にも書いたようにこれを1アイテムずつではなくどんどん溜めこんで一気にプリント・アウトしようというのです。
この暑い中、珍しく午後になっても2階のPCのある部屋でずっと作業をしていました、こんなことができたのもこの前買った扇風機のおかげです。
それはともかく出来たプロトタイプのマクロは下記のようなもの。
Sub バッファリング()
Dim 行範囲 As Long
Dim 列範囲 As Long
Dim コピー元 As Range
Dim データ行 As Long
Dim 追加行 As Long
Dim 最終行 As Long
Dim 予想行 As Long
Dim ページ As Long
With Application
.ScreenUpdating = False
Worksheets("通常品").Activate
行範囲 = Range("A65536").End(xlUp).Row
列範囲 = Cells(6, 1).End(xlToRight).Column
Set コピー元 = Range(Cells(6, 1), Cells(行範囲, 列範囲))
データ行 = コピー元.Rows.Count
Worksheets("印刷シート").Activate
追加行 = Cells(1).CurrentRegion.Rows.Count '図がない時の初期値
For Each 図 In ActiveSheet.Shapes
最終行 = 図.BottomRightCell.Row '図の一番下の位置を求める
Next
'貼りつける前のデータ量予測
予想行 = .RoundUp((最終行 + データ行 + 3)/39,0)
'現在のデータ量
ページ = .RoundUp(最終行 / 39, 0)
If ページ = 0 Then ページ = 1 '初めてのときのページ初期値
If 予想行 > ページ Then '予想データが現在データを
追加行 = ページ * 39 + 1 '超えるときページ換え
Else
追加行 = 追加行 + 最終行 '超えない時は現在ページに追加
End If
Worksheets("通常品").Range("A4:A5").Copy '注番と型番を
With Range(Cells(追加行, 1), Cells(追加行 + 2, 1))
.PasteSpecial Paste:=xlPasteValues '値としてコピ&ペ
.Font.Name = "HG丸ゴシックM-PRO"
.Font.Size = 11
.Font.Bold = True
End With
Cells(追加行 + 2, 1).Select '貼り付け先を選択
コピー元.CopyPicture _
Appearance:=xlPrinter, _
Format:=xlScreen 'データを図として
Worksheets("印刷シート").Pictures.Paste '貼り付け
Worksheets("通常品").Activate
.ScreenUpdating = True
End With
End Sub
プリント・アウトするときは罫線は色の付いた部分だけを残し、FAXで送るために色も抜く。
実はこの「色」だが色の頭文字を入力するとその瞬間にイベント・マクロで背景色を変えています、結構苦労してこの機能を盛り込んだのですが出来上がってからハタと考えました、「FAXって白黒だよなぁ」って・・・、しばらく黙っていたんだけど案の定それを指摘されました。
「この色ってFAXで送るんだからあまり意味が・・・」
「う、うるへ～」
「で、でも、色が出るから入力するとき判りやすいしとてもきれいです。」
というわけで全く無駄になったわけではありません、それに赤とか緑なんてそのまんまの色だとExcelは目にきついので気を使ってライト系の色にしてあるのです、これが割合評判がいい。
最新版の原本は会社にあるのでこのプロトタイプを元に来週修正作業をやるつもりです。
前にも書いたようにこれを1アイテムずつではなくどんどん溜めこんで一気にプリント・アウトしようというのです。
この暑い中、珍しく午後になっても2階のPCのある部屋でずっと作業をしていました、こんなことができたのもこの前買った扇風機のおかげです。
それはともかく出来たプロトタイプのマクロは下記のようなもの。
Sub バッファリング()
Dim 行範囲 As Long
Dim 列範囲 As Long
Dim コピー元 As Range
Dim データ行 As Long
Dim 追加行 As Long
Dim 最終行 As Long
Dim 予想行 As Long
Dim ページ As Long
With Application
.ScreenUpdating = False
Worksheets("通常品").Activate
行範囲 = Range("A65536").End(xlUp).Row
列範囲 = Cells(6, 1).End(xlToRight).Column
Set コピー元 = Range(Cells(6, 1), Cells(行範囲, 列範囲))
データ行 = コピー元.Rows.Count
Worksheets("印刷シート").Activate
追加行 = Cells(1).CurrentRegion.Rows.Count '図がない時の初期値
For Each 図 In ActiveSheet.Shapes
最終行 = 図.BottomRightCell.Row '図の一番下の位置を求める
Next
'貼りつける前のデータ量予測
予想行 = .RoundUp((最終行 + データ行 + 3)/39,0)
'現在のデータ量
ページ = .RoundUp(最終行 / 39, 0)
If ページ = 0 Then ページ = 1 '初めてのときのページ初期値
If 予想行 > ページ Then '予想データが現在データを
追加行 = ページ * 39 + 1 '超えるときページ換え
Else
追加行 = 追加行 + 最終行 '超えない時は現在ページに追加
End If
Worksheets("通常品").Range("A4:A5").Copy '注番と型番を
With Range(Cells(追加行, 1), Cells(追加行 + 2, 1))
.PasteSpecial Paste:=xlPasteValues '値としてコピ&ペ
.Font.Name = "HG丸ゴシックM-PRO"
.Font.Size = 11
.Font.Bold = True
End With
Cells(追加行 + 2, 1).Select '貼り付け先を選択
コピー元.CopyPicture _
Appearance:=xlPrinter, _
Format:=xlScreen 'データを図として
Worksheets("印刷シート").Pictures.Paste '貼り付け
Worksheets("通常品").Activate
.ScreenUpdating = True
End With
End Sub
プリント・アウトするときは罫線は色の付いた部分だけを残し、FAXで送るために色も抜く。
実はこの「色」だが色の頭文字を入力するとその瞬間にイベント・マクロで背景色を変えています、結構苦労してこの機能を盛り込んだのですが出来上がってからハタと考えました、「FAXって白黒だよなぁ」って・・・、しばらく黙っていたんだけど案の定それを指摘されました。
「この色ってFAXで送るんだからあまり意味が・・・」
「う、うるへ～」
「で、でも、色が出るから入力するとき判りやすいしとてもきれいです。」
というわけで全く無駄になったわけではありません、それに赤とか緑なんてそのまんまの色だとExcelは目にきついので気を使ってライト系の色にしてあるのです、これが割合評判がいい。
最新版の原本は会社にあるのでこのプロトタイプを元に来週修正作業をやるつもりです。
