[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセルのマクロを使用して連続印刷するコード』（JIN）
エクセルのマクロでマクロを使った連続印刷について
印刷該当データでフィルタをした状態
（フィルタをしているので１０行目から始まったり、次が１５行目だったりまちまちになります）
「Ｓ列」が同じ「文字単位のデータ」
（同じ文字単位は、最大で５行・最小で１行つづきます。）
（文字単位のデータは、「1RG8T」や「12345」の様な５桁の「数字」「英数字込」「英字」だけの文字になります）
Ｂ列〜ＡＨ列までをコピーして別シートに値貼付
（貼付は、印刷設定をしているシートに張り付ける形になります。）
張付たデータを印刷⇒データクリア⇒元データに戻り⇒先ほどコピーした「文字単位のデータ」の次の行から同じように連続印刷する様なマクロは可能でしょうか？
１行目から５行目までが「1RG8T」で６行目が「12345」なら
最初に「1RG8T」の５行目までを印刷して
次に「12345」の１行目を印刷するという形です。
キーになるのは、「文字単位のデータ」になります。
以上説明が難しくて分かりずらいかも知れませんが式を教えてください
よろしくお願いします。
＜ 使用 Excel：unknown、使用 OS：unknown ＞
こんにちわ ＾＾ なぁ〜んとなく。概略は理解できるのですが。 フイルター後、のデーターをコピーしたものを 印刷する部分をエクセルの表形式で←ちょい面倒ですが 詳しくご説明賜ると、お手伝い出来るかもしれません ↑ 多分ですが。。。＾＾；
http://www.excel.studio-kazu.jp/kw/20110209184943.html
を、拝借すれば、簡単ですよ。 フイルターコピーした表 印刷レイアウトの表 m(__)m （隠居Ｚ） 2021/09/16(木) 12:38
やりたい事は、種類が「別注」で管理番号が同じ明細は一緒に印刷を行う
種類が「除外」は印刷しない様にする
管理番号は同じ文字は最大で５行あり、１行の時も、２行の時も、３行の時も、４行の時もあります。
（Ａ列は無視して下さい、別の事で使う数式が入っているだけです。）
コピーする場所は、Ｂ列からＦ列までになります。
コピーして、別シートに貼付⇒印刷⇒貼付データをクリア⇒元シートに戻り同じことを繰り返す。
を最終行までという形です。
行数は多い時で５０００行ぐらいです（印刷する行は１００もありません）
|[A]|[B] |[C] |[D] |[E] |[F]
[1] | |処理日 |得意先名|商品名|管理番号|種類
[2] | 1|20210915|A社 |商品1|1RG8A |別注
[3] | 0|20210915|B社 |商品2 |1RG9V |別注
[4] | 0|20210915|A社 |商品1 |1RGD9 |除外
[5] | 0|20210915|A社 |商品2 |1RGD9 |除外
[6] | 0|20210915|B社 |商品3 |1RGDL |別注
[7] | 1|20210915|C社 |商品4 |1RGE0 |別注
[8] | 0|20210915|D社 |商品5 |1RGE1 |別注
[9] | 1|20210915|E社 |商品6 |1RGE2 |除外
[10]| 0|20210915|F社 |商品7 |1RGE3 |別注
[11]| 1|20210915|G社 |商品1 |1RGE4 |別注
[12]| 1|20210915|G社 |商品2 |1RGE4 |別注
[13]| 1|20210915|G社 |商品3 |1RGE4 |別注
[14]| 1|20210915|G社 |商品4 |1RGE4 |別注
以上よろしくお願いします。
（JIN） 2021/09/16(木) 13:31
こんにちわぁ ＾＾
こんなかんじでせうか。←かなりあやしぃA^^;
外していましたら、お許しを。。。m(_ _)m
ゴミ箱ポイ、お願いします。
Sheet1がご提示の情報、Sheet2は初期化され、情報が書き込まれます
新規ブックにてお試しを。
でわでわ。m(_ _)m
Option Explicit
Sub OneInstanceMain()
Dim r As Range
Dim ws2 As Worksheet
Dim zD As Object
Dim vAr As Variant
Dim t As Double
t = Timer
Set zD = CreateObject("Scripting.Dictionary")
Set ws2 = Worksheets("Sheet2")
ws2.UsedRange.Clear
With Worksheets("Sheet1")
Set r = .Cells(1).CurrentRegion
For Each vAr In r.Rows
If vAr.Columns(5).Value <> "管理番号" And vAr.Columns(5).Value <> "" Then
zD(vAr.Columns(5).Value) = Empty
End If
Next
For Each vAr In zD
With ws2
.Range("J1").Resize(, 2) = Array("管理番号", "種類")
.Range("J2:K2").NumberFormatLocal = "@"
.Range("J2").Resize(, 2) = Array("=" & vAr, "<>除外")
r.AdvancedFilter xlFilterCopy, ws2.Range("J1:K2"), ws2.Cells(1), False
If .Cells(2, 1) <> "" Then
.PrintPreview
End If
.UsedRange.Clear
End With
Next
End With
zD.RemoveAll
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
（隠居Ｚ） 2021/09/16(木) 16:35
おしえてください、
Sheet1の範囲はどこで決めているのでしょうか？
それと、Sheet2のA1からデータを張り付けてますが
そのデータを張り付ける場所を指定するにはどうしたらいいのでしょうか？
自分の加工したエクセルデータは、AB2からBH6までで張り付けてます。
1行目はタイトルです
.Range("J1").Resize(, 2) = Array("管理番号", "種類")
.Range("J2:K2").NumberFormatLocal = "@"
.Range("J2").Resize(, 2) = Array("=" & vAr, "<>除外")
このJ1・K2は、そのABに合わせてBJ1・BK2の様にしても問題ないのでしょうか？
（JIN） 2021/09/17(金) 14:34
こんにちわ ＾＾
Sheet1の範囲は
With Worksheets("Sheet1")
Set r = .Cells(1).CurrentRegion
です。[A1セルでコントロールと＊を押したとき選択される範囲です]
Sheet2書き出し位置は
r.AdvancedFilter xlFilterCopy, ws2.Range("J1:K2"), ws2.Cells(1), False
~~~~~~~~~~~~
↑ ここ
.Range("J1").Resize(, 2) = Array("管理番号", "種類")
.Range("J2:K2").NumberFormatLocal = "@"
.Range("J2").Resize(, 2) = Array("=" & vAr, "<>除外")
これは、印刷のお邪魔にならないと場所ならどこでも、＾＾；
ず〜と右端の関係無い場所の方が良いですよ。普通は用事が終われば消すのですが
ま、消し忘れても、印刷範囲に無ければ関係無いかと。。。＾＾；。m(_ _)m
消し忘れしてまして済みません。
注意事項
ただ、sheet2は全消去されますので、使用中のシートの一部分にコピペするなら
Shheet2を作業シートとし、書き出されたものを再度、ご必要な箇所にこっそり
書込むとかの方が無難ですよ。でわm(_ _)m
（隠居Ｚ） 2021/09/17(金) 14:53
張り付けるシートを「一時貼付場所」に変え
データが張り付く場所をBA1BB2に変えたのですが
タイトルしか張り付かなくなってしまったのです…
何がいけないのでしょうか？
Option Explicit
Sub OneInstanceMain()
Dim r As Range
Dim ws2 As Worksheet
Dim zD As Object
Dim vAr As Variant
Dim t As Double
t = Timer
Set zD = CreateObject("Scripting.Dictionary")
Set ws2 = Worksheets("一時貼付場所")
ws2.UsedRange.Clear
With Worksheets("Sheet1")
Set r = .Cells(1).CurrentRegion
For Each vAr In r.Rows
If vAr.Columns(5).Value <> "管理番号" And vAr.Columns(5).Value <> "" Then
zD(vAr.Columns(5).Value) = Empty
End If
Next
For Each vAr In zD
With ws2
.Range("BA1").Resize(, 2) = Array("管理番号", "種類")
.Range("BA2:BB2").NumberFormatLocal = "@"
.Range("BA2").Resize(, 2) = Array("=" & vAr, "<>除外")
r.AdvancedFilter xlFilterCopy, ws2.Range("BA1:BB2"), ws2.Cells(1), False
If .Cells(2, 1) <> "" Then
.PrintPreview
End If
.UsedRange.Clear
End With
Next
End With
zD.RemoveAll
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
（JIN） 2021/09/17(金) 19:10
こんばんわ ＾＾ 夕方から、回鍋肉を作っていまして。。。今拝見いたしました。 １．Sheet1の情報が、ご提示の内容と違うから。 ２．抽出条件を書き込むセルがBA1:BB2になっています ３．抽出先はシート 一時貼付場所 のＡ１です。 ２．３．はそれでよいような気がしますので 多分１．が原因かと。管理番号はシート Sheet1のＥ列ですか でわ。m(_ _)m （隠居Ｚ） 2021/09/17(金) 20:27
本番で使用するエクセルは、Sheet1に印刷レイアウトのデータを置き
コピーしたデータを別のセルに反映させる
コピーしたデータが全画面クリアになるとの事でしたので
さらに「一時貼付場所」なる別のシートを作成
イコールなどで反映させる事にします。
また、Sheet1の１行目にはマクロのボタンがあります、これはクリアでは消えないですが特に問題はないでしょうか？
本番で使用する印刷レイアウトの表は
Sheet1の
管理番号：Ｓ列
種類：ＡＨ列になります
データの最終列はＡＨ列になります。
例題では、レイアウト表が物凄いことになってしまうので
Sheet1の
管理番号：Ｅ列
種類：Ｆ列にしていました
本番の最終列がＡＨ列の為、余裕をもって("BA1:BB2"),にしました。
そこで下記に致しました。
.Range("BA1").Resize(, 2) = Array("管理番号", "種類")
.Range("BA2:BB2").NumberFormatLocal = "@"
.Range("BA2").Resize(, 2) = Array("=" & vAr, "<>除外")
r.AdvancedFilter xlFilterCopy, ws2.Range("BA1:BB2"), ws2.Cells(1), False
どうでしょうか？
純粋に
ＪやＫをＢＡやＢＢに書き換えればいいだけかと思っちゃいました(´;ω;｀)
すみません、よろしくお願いいたします。
（JIN） 2021/09/18(土) 10:09
おはようございます ＾＾
なにか、行き違いがある様な気がするのですが
Sheet1は大事な元表なので、フイルター処理だけで、削除、変更等は
一切行っておりません。フイルター後の情報と抽出条件をSheet2を初期化
後、書込んでいるだけですが。
（JIN）さん 2021/09/17(金) 19:10
の変更コードでもSheet1が以前のままなら[テストデーター]問題なく動い
ておりましたですよ。
最初の方で管理番号の一意なキーを作成してそれを基準にフイルター処理
していますので、そこを、ご修正賜れば、多分、お望みの結果が一時貼付場所
に作成されると思います。
For Each vAr In r.Rows
If vAr.Columns(5).Value <> "管理番号" And vAr.Columns(5).Value <> "" Then
zD(vAr.Columns(5).Value) = Empty
End If
Next
の全ての
vAr.Columns(5).Value
を
vAr.Columns(19).Value
[E列は左から5ばんめなので5、Ｓ列は19番目なので、19です。]
に変えてみて下さい、種類は 除外 で固定です。除外以外は何でも 印刷対象です。←＾＾；、。。。m(_ _)m （隠居Ｚ） 2021/09/18(土) 10:51
追伸です。。。＾＾ Sheet1にボタンがあるとの事でしたが 本番情報の項目開始のセル番地はA1では無いのでしょうか もしそうでなければ、さらなる、修正が、必要かも （隠居Ｚ） 2021/09/18(土) 11:10
本番エクセルが会社にある火曜日ないとできないのでそこで試します。
持って帰るの忘れました…
長く付き合ってくださってありがとうございます。
もう少しだけお願い致します。
（JIN） 2021/09/20(月) 09:36
おはようございます ＾＾ うまく動くといいですね。 火曜日は外出が予定されています。夜には戻っておりますので お許しを。。。＾＾；。。。何かあれば、他の回答者様がアド バイス下さるかもしれませんね。(#^^#)ｖ m(_ _)m （隠居Ｚ） 2021/09/20(月) 10:42
それは難儀でしたね。 どうぞ、お大事に。。。m(_ _)m （隠居Ｚ） 2021/09/21(火) 17:52
|[A]|[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA] |[AB] |[AC] |[AD] |[AE] |[AF] |[AG] |[AH]
[1]| |処理日 |納期 |得意先|得意先名|宛名|宛名名称|商品CD |商品名 |入枚 |CS数 |荷姿|総数量|売上金額|仕入先名 |仕入先連絡|伝票適用|客先発注番号|管理番号|行番号|SC伝票番号|郵便 |住所 |電話番号 |自動FAX |売上単価|仕入単価|作成日 |作成時間|作成者|作成者名|仕入先|ACOS送信時間|別注品
[2]| 0|20210922|20210924|M2892 |Ａ社 |ZZ |Ａ社 |08390321|ヘアセット | 50| 1|CS | 50| 1800|頭会社 | | | |1RIVU | 1|U0870 |郵便１|住所１|電話番号１|03-0000-0000| 36| 32|20210922| 083422| 19212|樋田 |MEA34 | 084104|除外
[3]| 0|20210922|20210924|M2892 |Ａ社 |ZZ |Ａ社 |08390975|マイスターｍｉｎｉ| 50| 1|CS | 50| 1800|頭会社 | | | |1RIVU | 2|U0870 |郵便２|住所２|電話番号２|03-0000-0000| 36| 32|20210922| 083422| 19212|樋田 |MEA34 | 084104|除外
[4]| 0|20210922|20210924|M2892 |Ａ社 |ZZ |Ａ社 |08390568|エキスプレス | 50| 1|CS | 50| 1900|頭会社 | | | |1RIVU | 3|U0870 |郵便３|住所３|電話番号３|03-0000-0000| 38| 34|20210922| 083422| 19212|樋田 |MEA34 | 084104|除外
[5]| 0|20210922|20210928|M4107 |Ｂ社 |ZZ |Ｂ社 |03988307|名入タオル１ |10000| 4|CS | 40000| 11600|タオル会社| | |8589-153 |1RIVW | 1|U0874 |郵便４|住所４|電話番号４|03-0000-0000| 0.29| 0.24|20210922| 083943| 22007|崇本 |MET28 | 084104|別注
[6]| 1|20210922|20210927|M1653 |Ｃ社 |1N |Ｚ店 |03917191|名入タオル５ | 1|10000|枚 | 10000| 5000|日本販売 | | | 4088061701|1RIWM | 1| 48303|郵便５|住所５|電話番号５|03-0000-0000| 0.5| 0.3|20210922| 085552| 41303|吉村 |ME283 | 090105|別注
[7]| 1|20210922|20211001|M1653 |Ｃ社 |1N |Ｚ店 |03917191|名入タオル１０ |20000| 1|CS | 20000| 10000|日本販売 | | | 4088061801|1RIWQ | 1| 48304|郵便６|住所６|電話番号６|03-0000-0000| 0.5| 0.3|20210922| 085655| 19212|樋田 |ME283 | 090105|別注
下記は本番用に頂いたコードの数字を変えただけのものです。
Option Explicit
Sub OneInstanceMain()
Dim r As Range
Dim ws2 As Worksheet
Dim zD As Object
Dim vAr As Variant
Dim t As Double
t = Timer
Set zD = CreateObject("Scripting.Dictionary")
Set ws2 = Worksheets("一時貼付場所")
ws2.UsedRange.Clear
With Worksheets("Sheet1")
Set r = .Cells(1).CurrentRegion
For Each vAr In r.Rows
If vAr.Columns(19).Value <> "管理番号" And vAr.Columns(19).Value <> "" Then 'Columns(19)が左から何列目の意味Ｓ列は19番目
zD(vAr.Columns(19).Value) = Empty
End If
Next
For Each vAr In zD
With ws2
.Range("BA1").Resize(, 2) = Array("管理番号", "種類")
.Range("BA2:BB2").NumberFormatLocal = "@"
.Range("BA2").Resize(, 2) = Array("=" & vAr, "<>除外")
r.AdvancedFilter xlFilterCopy, ws2.Range("BA1:BB2"), ws2.Cells(1), False
If .Cells(2, 1) <> "" Then
.PrintPreview
End If
.UsedRange.Clear
End With
Next
End With
zD.RemoveAll
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
.Range("BA1").Resize(, 2) = Array("管理番号", "種類")
は邪魔にならない場所にしただけですのでどこでも大丈夫です
コード上でＦ８で一個一個処理をしてるのですが、タイトル行のみの表示になります…
何度も何度もすみません、時間がありましたらお付き合いくださいませ。
（JIN） 2021/09/22(水) 12:53
こんにちわ〜＾＾ 腰痛、大丈夫ですか？お大事にして下さいませ。m(_ _)m ちょい、見てみますね、暫時お待ちください。 （隠居Ｚ） 2021/09/22(水) 13:58
お待たせいたしました。＾＾
抽出条件の項目名
種類
を
ＡＨ列の項目名
別注品
に変えてみて下さい。
.Range("BA1").Resize(, 2) = Array("管理番号", "種類")
〜〜〜〜
↑ ここ
m(_ _)m
（隠居Ｚ） 2021/09/22(水) 14:28
種類も違う名称にしてましたね(-_-;)
ありがとうございます！
そして、できました！
そして、腰は痛いです…今週は休みが多くて良かった．．．
本当に長い間ありがとうございました。
また機会があれば宜しくお願い致します。
本当にありがとうございました。
（JIN） 2021/09/22(水) 16:11
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.