[[20210816092728]]　『条件にあったシートを各ファイルから探して印刷し』（すず）　ページの最後に飛ぶ

『条件にあったシートを各ファイルから探して印刷したい。』（すず）

すいません、仕様の変更を言われて、困ってしまい、質問させてもらいました。
ファイルはすべて同じフォルダにおきます。ファイル名は、
入力ファイルの
入力
と、データファイルの
100、200、…1000
です。
100～1000ファイルに印刷したいシートがあります。
例えば、100なら、
シート名は、101～199が、
200なら、
シート名は201～299
といったかんじで作成されています。

この各シートの印刷範囲は、A1～DF43です。
また、CF1、CJ1、CO1、CX1セルには、
入力ファイルのsheet1にある
組、番、氏、名のデータが反映されるようにしたいです。
つまり、組のB3～B100が、CF1に
　　　　番のC3～C100が、CJ1に
　　　　氏のD3～D100が、CO1に、
　　　　名のE3～E100が、CX1にです。
F2、G2、…には、各データ内のシート名が入力されています、つまり、
101、102、…1098，1099
です。

入力ファイルのsheet1のA1セルにマクロボタンを作成したいです。

そこで、欲しい動作は、入力ファイルのマクロボタンをクリックしたら、
?@3行目のF3、G3、…のデータを参照して、空白なら無視。
　1が入力されていたら、それに対応するシートを選ぶ。
　つまり、105と207にだけ1が入力されていたら、
　ファイル名100の105シートと、ファイル名200の207シートを印刷する。
?A?@の印刷時には、上記のように組、番、氏、名が反映される。
?B3行目の印刷が終わったら、4行目に移って印刷。
?C入力ファイルのB,C列にデータがなくなったら、マクロ終了。

です。
よろしくお願いいたします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

して、どこまで出来ていてどこで詰まっているのですか？
ずらずらと発注のようなことを書かれましても質問内容がわからないのですが・・

（もこな２） 2021/08/16(月) 10:40

反応がないですが、ニックネームと内容から推測して↓の続きですよね。たぶん。
[[20210612163612]]　『表のデータと同じ番号のシートを印刷したい。』（すず）

とりあえず、質問とは関係ないですが何点か。

■１
この掲示板では丸付き数字などの環境依存文字は使わないほうがいいですよ。
（環境によっては文字化けしちゃうので）

■２
質問掲示板で提示のあったコードやネットで見つけたコードを研究するには【ステップ実行】という方法が便利ですよ。

ステップ実行という言葉を聞いたことがなければ↓を読んでみてください。

 【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html

また、以下も知っておいて損は無いと思います。

 【イミディエイトウィンドウ】
https://www.239-programing.com/excel-vba/basic/basic024.html
https://excel-ubara.com/excelvba1/EXCELVBA486.html

 【ローカルウィンドウ】
https://excel-ubara.com/excelvba4/EXCEL266.html
http://excelvba.pc-users.net/fol8/8_2.html

 【ブレークポイント】
https://www.239-programing.com/excel-vba/basic/basic022.html
https://www.tipsfound.com/vba/01010

■３
ということで、もしも以前に提示されたコードをベースに改良を加えたいということなら、まずそのコードの研究から始めてみてはどうでしょうか？

（もこな２） 2021/08/16(月) 11:50

発注書か

ちょっと笑ってしまった。
（ごめんなさい。） 2021/08/16(月) 12:05

皆様、
発注書、すいません。
その通りだと思います。
言われたことが全然理解できていなくて、全部ｗかあらない、って感じなのです。
あつかましくてすいません。

教えていただいたURL、見て試してみようと思います。

すいません。
（すず） 2021/08/16(月) 17:34

書き忘れてしまいました。
何か1つと言われたら、
101～199ならFILE名100から当該シートを選んで印刷すること。
201～299ならFILE名200から当該シートを選んで印刷すること。
だと思います。
（すず） 2021/08/16(月) 17:36

 200の場合は？
（通りすがり） 2021/08/16(月) 17:44

 参考まで。

Sub test()

 Dim num(5) As Integer
 Dim i As Integer
  num(0) = 100
  num(1) = 101
  num(2) = 109
  num(3) = 200
  num(4) = 201
  num(5) = 209
  For i = 0 To 5
   MsgBox num(i) & vbCrLf & Int(num(i) / 100)
  Next i
End Sub
（通りすがり） 2021/08/16(月) 17:48

■４
＞全部ｗかあらない
落ち着いて理解していきましょう。

まず必要な処理を分解して考えると

 入力ファイルの？？？シートのF3セルから順番に右にみていき、もしも、1が立っているセルがあったら
 　(1)２行目の【セルの値】から、必要なシートが格納されているブック名を調べる
   (2)↑のブックを開く
   (3)該当のシートを印刷する
   (4)ほかに印刷が必要なシートがないか順番にチェックする
   (5)n番台がなくなったら（他に印刷の必要なシートがないことが確定したら）(1)のブック を閉じる

ですよね。

まずは、印刷はさておきブックを開くところを考えてみましょう

■５
既に回答のあるところですが、シート名からブック名を調べるには、百の単位未満を切り捨てれば計算で求めることができますよね。

よってこんな感じです

    Sub 研究01()
        Dim i As Long

        With ActiveSheet
            For i = 6 To .Cells(2, .Columns.Count).End(xlToLeft).Column
                If .Cells(3, i).Value = 1 Then
                    MsgBox .Cells(2, i).Value & "シートは" & vbLf & Int(.Cells(2, i).Value / 100) * 100 & ".xls にあります"
                End If
            Next
        End With
    End Sub

■６
そして、ブックは全部同じフォルダにあるということですから、ファイル（ブック）のプルパスは、【マクロが書いてあるブックが存在するフォルダパス】と【ブック名】
を組み合わせればよいですよね。
よって、こんな風にすればよいです。

    Sub 研究02()
        Dim ブックパス As String
        ブックパス = ThisWorkbook.Path & "\" & "ブック名"

        MsgBox "↓を開けばおｋ" & vbLf & ブックパス
    End Sub

■７
ここまでで、開く必要があるブックのフルパスを調べることができましたので実際にブックを開いてみましょう。
ブックを開く命令は、【マクロの記録】を使うと調べることができます。

まずはこの辺りまで作ってみてはどうでしょうか？

 ※初めから複数のシート、ブックを対象にしようとすると混乱すると思うので、
   まずは１シート（１ブック）のみで考えることをお勧めします。

（もこな２） 2021/08/16(月) 19:17

ご親切にありがとうごさいます。
遅々として進まないかもしれませんが、教えていただいたことを頑張ってみます。
ありがとうございました。
（すず） 2021/08/17(火) 08:16

老婆心ながら
面倒でも回答者の方の問いかけに対するレスと
提示された内容の結果の報告はした方が良いと思
います。
（匿名希望） 2021/08/17(火) 08:29

はい。すいません。
ありがとうございます
（すず） 2021/08/17(火) 09:14

余計なお世話ですが、↓ということは、ALG列まであるんですかね。
使いにくそうですね。

＞F2、G2、…には、各データ内のシート名が入力されています、つまり、
＞101、102、…1098，1099
＞です。

（きまぐれ） 2021/08/17(火) 10:30

そう言われたのでそのまま書いてしまいましたが、確かにすごい列数ですよね。

私は、3桁や4桁入力してでも103とか1034とか、必要な数字を入力した方が、対応する列に1を入力するよりいいと思ったのですが、やはりそう思われますか。

（すず） 2021/08/17(火) 11:26

そう思います。
（きまぐれ） 2021/08/17(火) 11:42

 通りすがり　さん　の
ご質問にお答えいただいていれば
今頃、解決していたかもですね。。。＾＾；
100、200、300　～　1000
というシート名は無いのでしょうか。
え
(・。・;
シート名ですよ。。。ね。↑　1099。。。(#^^#)
（隠居Ｚ） 2021/08/17(火) 12:28

すいません。
ファイル名
100　→　含まれているワークシートは101～199で、100というのはありません。
200　→　含まれているワークシートは201～299で、200というのはありません。・
・
・
1000 →　含まれているワークシート名は1001～1099で、1000というのはありません。

ということだったのです。
質問をちゃんと理解できていない、ということでしょうか。

（すず） 2021/08/17(火) 13:07

 ＞＞質問をちゃんと理解できていない、ということでしょうか。
いえ、決して。。。
私が、ご提示の内容を私の理解不足により掌握できていなかったという
意味で御座います。m(__)m
もう一つ教えて頂きたいのですが
印刷範囲がとても横に広範囲なのですが。一部を印刷エリアに
指定しておられるのでしょうか。それともページ分、枚数を
印刷で？。。。＾＾；。←　ちょっと気になったもので。 
入力ブック[入力.xlsm] Sheet1
想像図
違っていましたら、相違点を教えて下さい。
      |[A]|[B]|[C]  |[D] |[E] |[F]     |[G]     
 [1]  |   |   |     |    |    |        |        
 [2]  |   |組 |番   |氏  |名  |シート名|印刷標識
 [3]  |   |  1|10001|あ1 |む1 |     393|       1
 [4]  |   |  2|10002|あ2 |む2 |     716|       1
 [5]  |   |  3|10003|あ3 |む3 |     228|       1
 [6]  |   |  4|10004|あ4 |む4 |     330|       1
 [7]  |   |  5|10005|あ5 |む5 |     220|       1
 [8]  |   |  6|10006|あ6 |む6 |     417|       0
 [9]  |   |  7|10007|あ7 |む7 |     348|       0
 [10] |   |  8|10008|あ8 |む8 |     895|       1
 [11] |   |  9|10009|あ9 |む9 |     461|       0
 [12] |   | 10|10010|あ10|む10|     975|       1
 [13] |   | 11|10011|あ11|む11|     944|       1
 [14] |   | 12|10012|あ12|む12|     214|       1
 [15] |   | 13|10013|あ13|む13|     825|       1
 [16] |   | 14|10014|あ14|む14|     264|       1
 [17] |   | 15|10015|あ15|む15|     293|       0
 [18] |   | 16|10016|あ16|む16|     904|       0
 [19] |   | 17|10017|あ17|む17|     904|       1
 [20] |   | 18|10018|あ18|む18|     840|       0
 [21] |   | 19|10019|あ19|む19|     663|       0
 [22] |   | 20|10020|あ20|む20|     739|       0
 [23] |   | 21|10021|あ21|む21|     957|       0
 [24] |   | 22|10022|あ22|む22|     227|       0
 [25] |   | 23|10023|あ23|む23|     631|       1
 [26] |   | 24|10024|あ24|む24|     817|       1
 [27] |   | 25|10025|あ25|む25|     406|       1
 [28] |   | 26|10026|あ26|む26|     583|       0
 [29] |   | 27|10027|あ27|む27|     954|       1
 [30] |   | 28|10028|あ28|む28|     177|       1
 [31] |   | 29|10029|あ29|む29|     989|       0
 [32] |   | 30|10030|あ30|む30|     589|       0
 [33] |   | 31|10031|あ31|む31|     660|       1
 [34] |   | 32|10032|あ32|む32|     848|       0
 [35] |   | 33|10033|あ33|む33|     671|       0
 [36] |   | 34|10034|あ34|む34|     788|       1
 [37] |   | 35|10035|あ35|む35|     362|       1
 [38] |   | 36|10036|あ36|む36|     145|       1
 [39] |   | 37|10037|あ37|む37|     527|       1
 [40] |   | 38|10038|あ38|む38|     279|       1
 [41] |   | 39|10039|あ39|む39|     112|       1
 [42] |   | 40|10040|あ40|む40|     529|       0
 [43] |   | 41|10041|あ41|む41|     572|       0
 [44] |   | 42|10042|あ42|む42|     493|       0
 [45] |   | 43|10043|あ43|む43|     131|       1
 [46] |   | 44|10044|あ44|む44|     828|       1
 [47] |   | 45|10045|あ45|む45|     884|       1
 [48] |   | 46|10046|あ46|む46|     123|       0
 [49] |   | 47|10047|あ47|む47|     733|       1
 [50] |   | 48|10048|あ48|む48|     508|       0
 [51] |   | 49|10049|あ49|む49|     703|       1
 [52] |   | 50|10050|あ50|む50|     807|       1
 [53] |   | 51|10051|あ51|む51|     837|       1
 [54] |   | 52|10052|あ52|む52|     981|       0
 [55] |   | 53|10053|あ53|む53|     438|       0
 [56] |   | 54|10054|あ54|む54|     697|       1
 [57] |   | 55|10055|あ55|む55|     739|       1
 [58] |   | 56|10056|あ56|む56|     944|       0
 [59] |   | 57|10057|あ57|む57|     639|       1
 [60] |   | 58|10058|あ58|む58|     106|       0
 [61] |   | 59|10059|あ59|む59|     903|       0
 [62] |   | 60|10060|あ60|む60|     976|       0
 [63] |   | 61|10061|あ61|む61|     149|       0
 [64] |   | 62|10062|あ62|む62|     498|       1
 [65] |   | 63|10063|あ63|む63|     704|       1
 [66] |   | 64|10064|あ64|む64|     172|       0
 [67] |   | 65|10065|あ65|む65|     242|       1
 [68] |   | 66|10066|あ66|む66|     333|       1
 [69] |   | 67|10067|あ67|む67|     143|       1
 [70] |   | 68|10068|あ68|む68|     919|       1
 [71] |   | 69|10069|あ69|む69|     142|       1
 [72] |   | 70|10070|あ70|む70|     207|       0
 [73] |   | 71|10071|あ71|む71|     688|       1
 [74] |   | 72|10072|あ72|む72|     304|       1
 [75] |   | 73|10073|あ73|む73|     648|       1
 [76] |   | 74|10074|あ74|む74|     436|       0
 [77] |   | 75|10075|あ75|む75|     682|       1
 [78] |   | 76|10076|あ76|む76|     460|       0
 [79] |   | 77|10077|あ77|む77|     588|       1
 [80] |   | 78|10078|あ78|む78|     484|       1
 [81] |   | 79|10079|あ79|む79|     376|       0
 [82] |   | 80|10080|あ80|む80|     321|       1
 [83] |   | 81|10081|あ81|む81|     474|       0
 [84] |   | 82|10082|あ82|む82|     316|       0
 [85] |   | 83|10083|あ83|む83|     251|       1
 [86] |   | 84|10084|あ84|む84|     332|       0
 [87] |   | 85|10085|あ85|む85|     370|       1
 [88] |   | 86|10086|あ86|む86|     592|       0
 [89] |   | 87|10087|あ87|む87|     182|       1
 [90] |   | 88|10088|あ88|む88|     468|       1
 [91] |   | 89|10089|あ89|む89|     739|       0
 [92] |   | 90|10090|あ90|む90|     259|       1
 [93] |   | 91|10091|あ91|む91|     440|       0
 [94] |   | 92|10092|あ92|む92|     249|       1
 [95] |   | 93|10093|あ93|む93|     533|       1
 [96] |   | 94|10094|あ94|む94|     976|       0
 [97] |   | 95|10095|あ95|む95|     730|       1
 [98] |   | 96|10096|あ96|む96|     390|       0
 [99] |   | 97|10097|あ97|む97|     663|       1
 [100]|   | 98|10098|あ98|む98|     567|       0
（隠居Ｚ） 2021/08/17(火) 13:24

印刷範囲が広大なのは、セル幅を1にしているからで、B4横1枚に対応する範囲です。
また、入力ファイルの入力シートが無駄に横長なのは非効率的と指摘を受けましたし、
もともと私もそう考えていたので、その点は押し切ることにしたとして、以下のような入力画面にしたいと思います。

      |[A]|[B]|[C]  |[D] |[E] |[F]      |[G]      |[H]
 [1]  |   |   |     |    |    |         |         | 
 [2]  |   |組 |番   |氏  |名  |シート名1|シート名2|シート名3　…　　シート名50
 [3]  |   |  1|10001|あ1 |む1 |     103 |     104 |
 [4]  |   |  2|10002|あ2 |む2 |     101 |     103 |
 [5]  |   |  3|10003|あ3 |む3 |     228 |     502 |
 [6]  |   |  4|10004|あ4 |む4 |     330 |     333 |
 [7]  |   |  5|10005|あ5 |む5 |     220 |     601 |
 [8]  |   |  6|10006|あ6 |む6 |     417 |         |
 [9]  |   |  7|10007|あ7 |む7 |     348 |     812 |
 [10] |   |  8|10008|あ8 |む8 |     895 |     702 |
 [11] |   |  9|10009|あ9 |む9 |     461 |     501 |

 [12] |   | 10|10010|あ10|む10|     975 |     989 |
 [13] |   | 11|10011|あ11|む11|     944 |       1

その人毎に印刷を要するシートが違っていて、0枚とか、2枚とか、5枚とかです。
必要とするシート名を必要なだけ入力するようにした方が無駄が少なそうなきがしました。

何度もありがとうございます。

（すず） 2021/08/17(火) 14:31

前回同様、印刷開始と印刷終了の組、番を入力して印刷ですが、
前回と違うのは、そのシートが同じファイル内になくて、他のファイルに散在しているということです。
（すず） 2021/08/17(火) 14:41

横からですが、そういうレイアウトにするならこんな感じですかね

    Sub 研究03()
        Dim 行 As Long, 列 As Long, i As Long
        Dim ブック名 As String

        With ThisWorkbook.Worksheets("Sheet1")
            For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
                For 列 = 6 To .Cells(行, .Columns.Count).End(xlToLeft).Column
                    ブック名 = Int(.Cells(行, 列).Value / 100) * 100 & ".xlsx"
                    MsgBox "もしも「" & ブック名 & "」が開いてなかったら" & vbLf & ThisWorkbook.Path & "\" & ブック名 & "を開く"
                    MsgBox "必要な転記をしたら「" & .Cells(行, 列).Value & "」シートを印刷する"
                Next 列
            Next 行
        End With

        For i = 100 To 1100 Step 100
            MsgBox "もしも「" & i & "」ブックが開いていたら閉じる"
        Next i
    End Sub

（もこな２） 2021/08/17(火) 15:05

ありがとうございます。
ブックが開いていたら閉じるものですね。
これをきちんとやって常に同じ状態から始める、ということですね。
（すず） 2021/08/17(火) 15:52

いや、今回の場合は、ブックは一度開いたら全部の処理が終わるまで開きっぱなしのほうがいいと思いますよ。
（いちいち、開いて閉じてを繰り返したら時間ロスになるとおもうので）

（もこな２） 2021/08/17(火) 16:01

すいません、よくわかっていなくて。
ありがとうございます。
（すず） 2021/08/17(火) 16:05

繰り返しになりますが、始めから複数のブック、シートを考えると混乱しますから、【（すず） 2021/08/17(火) 14:31】のレイアウトでいえば、F3セルだけに注目して、そのシート”だけ”考えてみるとよいとおもいます。

それが理解できれば、あとは繰り返しの世界なので・・・

（もこな２） 2021/08/17(火) 17:05

 とりあえず　作ってみましたが。。。＾＾
自信ありません。きっと、もっとスマートで
完成度の高いコードが有ると思いますが
何とか動きますので、ご考察時の参考にでも。。。＾＾；
ブック読み込むだけで、10秒はかかるかも。。。
なんとか、コーヒータイムの間に印刷へ回せるかも。みたいな感じです
私もここの生徒なので
突っ込み大歓迎ですぅ～　(#^ ^#)v
シート名の確認は付けましたが、エラー処理等、ありません
Option Explicit
Sub OneInstanceMain03()
    Const zProgramID As String = "入力.xlsm"
    Dim zTb As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim n             As Long
    Dim nn            As Long
    Dim lr            As Long
    Dim lc            As Long
    Dim mcol()        As Variant
    Dim invflg        As Boolean
    Dim v()           As Variant
    Dim sNm()         As Variant
    Dim zErr()        As Variant
    Dim kumi          As Long
    Dim ban           As Long
    Dim lNm           As String
    Dim fNm           As String
    Dim r             As Range
    Dim zD            As Object
    Dim wBnm()        As Variant
    Dim vAr           As Variant
    Dim t             As Double
    t = Timer
    Set zTb = Workbooks(zProgramID)
    Set zD = CreateObject("Scripting.Dictionary")
    With zTb.Worksheets("Sheet1")
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        For i = 3 To lr
            ReDim Preserve mcol(j)
            mcol(j) = .Cells(i, .Columns.Count).End(xlToLeft).Column
            j = j + 1
        Next
        lc = Application.Max(mcol)
        Set r = .Range(.Cells(3, 2), .Cells(lr, lc))
        v = r.Value
    End With
    For i = LBound(v, 1) To UBound(v, 1)
        kumi = v(i, 1)
        ban = v(i, 2)
        lNm = v(i, 3)
        fNm = v(i, 4)
        For j = 5 To UBound(v, 2)
            If v(i, j) <> Empty Then
                If sNmAndNumchk(v(i, j)) Then
                    ReDim Preserve sNm(n)
                    sNm(n) = Array(v(i, j), Int(v(i, j) / 100) * 100 & ".xlsx", _
                                   kumi, ban, lNm, fNm)
                    n = n + 1
                    zD(Int(v(i, j) / 100) * 100 & ".xlsx") = Empty
                Else
                    ReDim Preserve zErr(nn)
                    zErr(nn) = r(i, j).Address(0, 0)
                    nn = nn + 1
                    invflg = True
                End If
            End If
        Next
    Next i
    If invflg Or zD.Count = 0 Then
        bclose zTb
        zD.RemoveAll
        MsgBox "情報に不都合が有りました修正後再起動してください" & Chr(13) & Join(zErr, Chr(13))
        Erase v, wBnm, sNm, zErr, mcol
        Exit Sub
    End If
    wBnm = zD.keys
    'Application.ScreenUpdating = False
    For Each vAr In wBnm
        If Dir(zTb.Path & "\" & vAr) <> "" Then
             Workbooks.Open zTb.Path & "\" & vAr
        End If
    Next
    'Application.ScreenUpdating = True
    For i = LBound(sNm) To UBound(sNm)
            j = 2
            With Workbooks(sNm(i)(1)).Worksheets(Trim(CStr(sNm(i)(0))))
                For Each vAr In Union(.Range("cf1"), .Range("cj1"), .Range("co1"), .Range("cx1"))
                    vAr.Value = sNm(i)(j)
                    j = j + 1
                Next
                With .PageSetup
                    .Orientation = xlLandscape
                    .PaperSize = xlPaperB4
                    '.Zoom = 70
                End With
                .PrintPreview
            End With
        DoEvents
    Next
    bclose zTb
    Erase v, wBnm, sNm, zErr, mcol
    zD.RemoveAll
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Sub bclose(ByVal wb As Workbook)
    Dim vAr           As Workbook
    For Each vAr In Workbooks
         If Not (wb Is vAr) Then
             vAr.Close False
         End If
    Next
End Sub
Private Function sNmAndNumchk(ByRef arg1 As Variant) As Boolean
    Dim i             As Long
    Dim vAr           As Variant
    For i = 1 To Len(arg1)
        If Mid(arg1, i, 1) Like "[0-9]" Then
            sNmAndNumchk = True
        Else
            sNmAndNumchk = False
            Exit Function
        End If
    Next
    If arg1 > 100 And arg1 < 1100 Then
        sNmAndNumchk = True
    Else
        sNmAndNumchk = False
        Exit Function
    End If
    For Each vAr In Array(200, 300, 400, 500, 600, 700, 800, 900, 1000)
        If arg1 = vAr Then
            sNmAndNumchk = False
            Exit Function
        End If
    Next
End Function
（隠居Ｚ） 2021/08/18(水) 11:52

ありがとうございます！
すごく助かります。
明日、プリンターのあるところで確認したいのですが、現時点でやってみました。
2行めを
Sub 印刷()
に変えてみました。

.PrintPreview　　を.PrintOut　に変えました。
すると、プレビューで止まらず、つながっていないプリンターにデーターを送っているみたいでした。
ただ、関係ないフォルダにフィアルを保存しようとしていました。？？？

それから、最後に

Private Sub zAcceptSe(ByRef startnum As Long, ByRef endnum As Long)

    Dim a             As Variant
    Dim b             As Variant
    a = Application.InputBox("開始する組と番を数値で入力して下さい", "開始組＆番", "11", , , , , 1)
    If TypeName(a) = "Boolean" Then End
    startnum = a
    b = Application.InputBox("終了する組と番を数値で入力して下さい", "終了組＆番", "13", , , , , 1)
    If TypeName(a) = "Boolean" Then End
    endnum = b
End Sub

を入れれば、開始の組番と終了の組番を指定できるかと思ったのですが、浅はかでした。
何度も申し訳ないのですが、前回と同じというわけではないのですね。
すいません。
よろしくお願いいたします。

（すず） 2021/08/18(水) 18:43

 こんばんは　＾＾
＞＞関係ないフォルダにフィアルを保存
一切保存はしていません
どうせ毎回、書き換える箇所の変更のみなので保存せず
ブックを閉じています。
シート名の有る行と同じ行のＢ～Ｅ列の
組、番、氏、名
を書き込んでいます。Previwでご確認を。
小さくて見えない場合は、虫メガネマークをクリックすれば
大きく表示されますよ。
違っていましたら、今一度、正解を、教えて下さい。。。A＾＾；
m(_ _)m
（隠居Ｚ） 2021/08/18(水) 19:44

追伸、
繋がっていないプリンターのキュー
お掃除してくださいね。。。＾＾；
余計なお世話でしたらすみません。。。
うっかり忘れると、えらい目にあう可能性も。。。
(#^.^#)
でわ
（隠居Ｚ） 2021/08/18(水) 19:50

プレビューが出ていたときに、組番を順に印刷しているのを確認しました。
それだけに、不思議でした。
印刷が全部終わった後に、名前をつけて保存の画面になったので。
.PrintPreview　　を.PrintOut
にする以外に何か触ってないか、チェックします。
プリンターのキューは、印刷されないでたまっている命令のことですよね。
気をつけます。

とにかくありがとうございます。
（すず） 2021/08/18(水) 20:14

 ＞＞開始の組番と終了の組番を指定できるかと思ったのですが、浅はかでした。 
 ＞＞前回と同じというわけではないのですね。
相済みません。。。思い出しました。私の方が迂闊だったようです。
前回同様、併用出来るようにしてみます。
Ｂ、Ｃ列の組、番　は以前と比較して
横並びが、縦並びに変わっただけですよね。←違っていれば教えて下さいね。
暫時御猶予を
m(_ _)m
（隠居Ｚ） 2021/08/18(水) 21:23

何度もありがとうございます。
はい。縦並びに変わりました。

いつもありがとうございます。
（すず） 2021/08/19(木) 05:26

 おはようございます　＾＾
一応組み込んでは見ましたが。。。いい加減な手抜きロジックにつき
不都合が有るやもしれません。
ＶＢＡもかなり精通しておられるようなので,現在のコードを全てご理解の上
将来は、ユーザーフォームに切替、きちんと4項目[開始組、番、終了組、番]
に分け処理された方がいいかも。。。
Sheet1 Ｂ列、Ｃ列の優先順位で、昇順に組と番が並んでいて、抜け[空]
が無い事が前程です。
3行目以降Ｂ～Ｅ列まで情報が有る列ならどこにシート名を入力して戴いても
取り込みます。←　多分。。。(￣▽￣)
ブック名判定は　通りすがり　さん　のご提案を使わせて戴きました。m(__)m
エラー処理、便利機能等は御座いません。でわ
m(_ _)m
Option Explicit
Sub 印刷検索付v01()
    Const zProgramID As String = "入力.xlsm"
    Dim zTb As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim n             As Long
    Dim nN            As Long
    Dim lR            As Long
    Dim lC            As Long
    Dim sKb           As Long
    Dim eKb           As Long
    Dim sRow          As Long
    Dim eRow          As Long
    Dim mCol()        As Variant
    Dim iNvflg        As Boolean
    Dim v()           As Variant
    Dim sNm()         As Variant
    Dim zErr()        As Variant
    Dim kUmi          As Long
    Dim bAn           As Long
    Dim lNm           As String
    Dim fNm           As String
    Dim r             As Range
    Dim zD            As Object
    Dim wBnm()        As Variant
    Dim vAr           As Variant
    Dim t             As Double
    t = Timer
    zAcceptSe sKb, eKb
    Set zTb = Workbooks(zProgramID)
    Set zD = CreateObject("Scripting.Dictionary")
    With zTb.Worksheets("Sheet1")
        lR = .Cells(.Rows.Count, 2).End(xlUp).Row
        For i = 3 To lR
            ReDim Preserve mCol(j)
            mCol(j) = .Cells(i, .Columns.Count).End(xlToLeft).Column
            j = j + 1
        Next
        lC = Application.Max(mCol)
        Set r = .Range(.Cells(3, 2), .Cells(lR, lC))
        v = r.Value
    End With
    For i = LBound(v, 1) To UBound(v, 1)
        If sKb = v(i, 1) & v(i, 2) Then sRow = i
        If eKb = v(i, 1) & v(i, 2) Then eRow = i
    Next
    If sRow < 1 Then
        sRow = 1
        eRow = 0
    End If
    For i = sRow To eRow
        kUmi = v(i, 1)
        bAn = v(i, 2)
        lNm = v(i, 3)
        fNm = v(i, 4)
        For j = 5 To UBound(v, 2)
            If v(i, j) <> Empty Then
                If sNmAndNumchk(v(i, j)) Then
                    ReDim Preserve sNm(n)
                    sNm(n) = Array(v(i, j), Int(v(i, j) / 100) * 100 & ".xlsx", _
                                   kUmi, bAn, lNm, fNm)
                    n = n + 1
                    zD(Int(v(i, j) / 100) * 100 & ".xlsx") = Empty
                Else
                    ReDim Preserve zErr(nN)
                    zErr(nN) = r(i, j).Address(0, 0)
                    nN = nN + 1
                    iNvflg = True
                End If
            End If
        Next
    Next i
    If iNvflg Or zD.Count = 0 Then
        bClose zTb
        zD.RemoveAll
        MsgBox "情報に不都合が有りました修正後再起動してください" & Chr(13) & Join(zErr, Chr(13))
        Erase v, wBnm, sNm, zErr, mCol
        Exit Sub
    End If
    wBnm = zD.keys
    For Each vAr In wBnm
        If Dir(zTb.Path & "\" & vAr) <> "" Then
             Workbooks.Open zTb.Path & "\" & vAr
        End If
    Next
    For i = LBound(sNm) To UBound(sNm)
        j = 2
        With Workbooks(sNm(i)(1)).Worksheets(Trim(CStr(sNm(i)(0))))
            For Each vAr In Union(.Range("CF1"), .Range("CJ1"), .Range("CO1"), .Range("CX1"))
                vAr.Value = sNm(i)(j)
                j = j + 1
            Next
            With .PageSetup
                .Orientation = xlLandscape
                .PaperSize = xlPaperB4
                '.Zoom = 70
            End With
            .Range("A1:DF43").PrintPreview
        End With
        DoEvents
    Next
    bClose zTb
    Erase v, wBnm, sNm, zErr, mCol
    zD.RemoveAll
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"    
End Sub
Private Sub bClose(ByVal wb As Workbook)
    Dim vAr           As Workbook
    For Each vAr In Workbooks
         If Not (wb Is vAr) Then
             vAr.Close False
         End If
    Next
End Sub
Private Function sNmAndNumchk(ByRef arg1 As Variant) As Boolean
    Dim i             As Long
    Dim vAr           As Variant
    For i = 1 To Len(arg1)
        If Mid(arg1, i, 1) Like "[0-9]" Then
            sNmAndNumchk = True
        Else
            sNmAndNumchk = False
            Exit Function
        End If
    Next
    If arg1 > 100 And arg1 < 1100 Then
        sNmAndNumchk = True
    Else
        sNmAndNumchk = False
        Exit Function
    End If
    For Each vAr In Array(200, 300, 400, 500, 600, 700, 800, 900, 1000)
        If arg1 = vAr Then
            sNmAndNumchk = False
            Exit Function
        End If
    Next
End Function
Private Sub zAcceptSe(ByRef startnum As Long, ByRef endnum As Long)
    Dim a             As Variant
    Dim b             As Variant
    a = Application.InputBox("開始する組と番を数値で入力して下さい", "開始組＆番", "11", , , , , 1)
    If TypeName(a) = "Boolean" Then End
    startnum = a
    b = Application.InputBox("終了する組と番を数値で入力して下さい", "終了組＆番", "13", , , , , 1)
    If TypeName(a) = "Boolean" Then End
    endnum = b
End Sub
（隠居Ｚ） 2021/08/19(木) 09:38

ありがとうございます！
プレビューをアウトに変えてもできました。
1組3番は13で、5組25番は525と入力してうまくいったのですが、それでいいのですよね。
上手くいったのだからそうなのでしょう。

本当にありがとうございます。
（すず） 2021/08/19(木) 10:07

 はい
それで、仮に番が10001なら
110001
1組の10001番で。行けるはずです。単純に組と番を繋いでるだけなので
A＾＾；
m(_ _)m
（隠居Ｚ） 2021/08/19(木) 10:15

残念ながらご自身で解明していこうというタイプの方ではないようですね。
であれば興味がないですし、隠居Ｚさんのお邪魔をしてもいけないのでROMに戻りますが、乗りかかったなんとやらなので提示だけしておきます。

★１
話が続くようであれば↓のようなコードが完成するはずでした。

    Sub 完成予定()
        Dim 行 As Long, 列 As Long, i As Long
        Dim ブック名 As String
        Dim WB As Workbook
        Dim dstSH As Worksheet

        With ThisWorkbook.Worksheets("Sheet1")
            For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
                For 列 = 6 To .Cells(行, .Columns.Count).End(xlToLeft).Column
                    ブック名 = Int(.Cells(行, 列).Value / 100) * 100 & ".xlsx"

                    On Error Resume Next
                    Set WB = Nothing
                    Set WB = Workbooks(ブック名)
                    On erro GoTo 0
                    If WB Is Nothing Then Workbooks.Open (ThisWorkbook.Path & "\" & ブック名)

                    Set dstSH = Workbooks(ブック名).Worksheets(.Cells(行, 列).Value)

                    dstSH.Range("CF1") = .Cells(行, "B").Value
                    dstSH.Range("CJ1") = .Cells(行, "C").Value
                    dstSH.Range("CO1") = .Cells(行, "D").Value
                    dstSH.Range("CX1") = .Cells(行, "E").Value

                    dstSH.PrintPreview

                Next 列
            Next 行
        End With

        On Error Resume Next
        For i = 100 To 1100 Step 100
           Workbooks(i & ".xlsx").Close False
        Next i
        On Error GoTo 0
    End Sub

★２
ただ、上記ですと、99シートあるブックが最大で11個開きっぱなしになってしまうので、隠居Ｚさんの「2021/08/17(火) 13:24」のレイアウトを参考に再考。

    Sub 再考バージョン()
        Dim 行 As Long, 列 As Long, 出力行 As Long
        Dim ブック名 As String
        Dim WB As Workbook
        Dim dstSH As Worksheet

        With Worksheets.Add(After:=ThisWorkbook.Worksheets(Worksheets.Count))
            .Name = "作業用"
        End With

        With ThisWorkbook.Worksheets("Sheet1")
            .Range("B2:F2").Copy Worksheets("作業用").Range("A1")
            出力行 = 2

            For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
                For 列 = 6 To .Cells(行, .Columns.Count).End(xlToLeft).Column
                    .Cells(行, "B").Resize(, 4).Copy Worksheets("作業用").Cells(出力行, "A")
                    .Cells(行, 列).Copy Worksheets("作業用").Cells(出力行, "E")
                    出力行 = 出力行 + 1
                Next 列
            Next 行

            Worksheets("作業用").Range("A1").CurrentRegion.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes
        End With

        With ThisWorkbook.Worksheets("作業用")
            For 行 = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                ブック名 = Int(.Cells(行, "E").Value / 100) * 100 & ".xlsx"

                On Error Resume Next
                Set WB = Nothing
                Set WB = Workbooks(ブック名)
                If WB Is Nothing Then Workbooks.Open (ThisWorkbook.Path & "\" & ブック名)
                On Error GoTo 0

                With Workbooks(ブック名).Worksheets(.Cells(行, "E").Value & "")
                    .Range("CF1").Value = ThisWorkbook.Worksheets("作業用").Cells(行, "A").Value
                    .Range("CJ1").Value = ThisWorkbook.Worksheets("作業用").Cells(行, "B").Value
                    .Range("CO1").Value = ThisWorkbook.Worksheets("作業用").Cells(行, "C").Value
                    .Range("CX1").Value = ThisWorkbook.Worksheets("作業用").Cells(行, "D").Value

                    .PrintPreview
                End With

                If ブック名 <> Int(.Cells(行 + 1, "E").Value / 100) * 100 & ".xlsx" Then
                    Workbooks(ブック名).Close False
                End If
            Next 行

            Application.DisplayAlerts = False
            .Delete
            Application.DisplayAlerts = True
        End With
    End Sub

このようにすれば11個も開きっぱなしになりませんね。
いずれも、混乱するといけませんから、隠居Ｚさんとのやり取りが終わって、時間に余裕があって、興味がわいたときに研究してみてください。

（もこな２） 2021/08/20(金) 14:27

コメント返信：

[ 一覧(最新更新順) ]

[[20210816092728]] 『条件にあったシートを各ファイルから探して印刷し』（すず） ページの最後に飛ぶ

[[20210816092728]]　『条件にあったシートを各ファイルから探して印刷し』（すず）　ページの最後に飛ぶ