エクセルの学校：全文検索：Hyper Estraier：フォルダ　ブック　シート　転記

Results of 1 - 1 of about 384 for フォルダ　ブック　シート　転記 (0.037 sec.)

フォルダ (4446), ブック (11580), シート (35662), 転記 (4285)

[[20130512101712]]: #score: 8791; @digest: 54375687c9b8fec49d7b30fe37bd1ab1; @id: 62298; @mdate: 2013-06-04T10:31:51Z; @size: 92005; @type: text/plain; #keywords: 問診 (265511), 診票 (257356), tsh (157129), 画書 (132539), fsh (124612), flist (117303), 員id (112604), 元ブ (95949), 社員 (70721), 員名 (60576), 間外 (51234), 人用 (47870), 者別 (41065), 計画 (40595), 目| (40385), 員番 (39207), wsh (38992), 当者 (32091), 存フ (31756), 担当 (26605), 月前 (25843), 所属 (25299), 分解 (22166), ブッ (19631), fname (17762), mypath (16539), 個人 (16092), 示頂 (15710), displayalerts (15639), shell (15196), range (13708), application (12376); 『データリストから担当ごとに振分』（はな）
はじめまして。 VBA初心者です。色々調べてみても未熟のためVBAを完成させることができないので御教示頂けませんでしょうか。よろしくお願い致します。月に一度処理をしならければならなく大変手を焼いています。時間外労働のデータを担当者別に新規ファイルに50件ほど作成しなければなりません。基になるデータから担当者ごと（ソート済）に新規ファイルを作成するというマクロ処理です。【基データ】タイトル等A1〜R4 A B ・・・・・ Q R 4 社員ID 社員名担当者ID 担当者名 ※A列とQ列は別の方です。 5 0000 あああ 6666 ○○ 6 1111 いいい 6666 ○○ 7 2222 ううう 7777 ■■ 8 3333 えええ 8888 △△ 9 4444 おおお 8888 △△ ↓ 【マクロ処理後】 6666○○ファイル.xls タイトル等A1〜R4 A B ・・・・・ Q R 4 社員ID 社員名担当者ID 担当者名 5 0000 あああ 6666 ○○ 6 1111 いいい 6666 ○○ 7777■■ファイル.xls タイトル等A1〜R4 A B ・・・・・ Q R 4 社員ID 社員名担当者ID 担当者名 5 2222 ううう 7777 ■■ 8888△△ファイル.xls タイトル等A1〜R4 A B ・・・・・ Q R 4 社員ID 社員名担当者ID 担当者名 5 3333 えええ 8888 △△ 6 4444 おおお 8888 △△ 会社PC WindowsXP Excel2003 自宅PC Windows 7 Excel2007 ---- いろんな方法があるけどエクセル操作をベースにすれば 1.元ブックの、このシートのQ4〜R●に対してフィルターオプションで重複を無視してT列あたりに抽出。これで、ユニークな担当者リストができあがる 2.このユニークな担当者リストのそれぞれに対して 1）新規ブックを生成(元ブックのシートから作成） 2）元ブックのA4〜Q●のリストから、ユニークな担当者リストのそれぞれの値を抽出キーにして新規ブックのシートのA4にフィルターオプションで抽出。こういった作業をマクロ記録し、あとはそれをベースに、領域の最後を動的に与えたり、ユニークな担当者リストのそれぞれを、フィルターオプションにループであたえるといったコードを加えれば完成すると思う。にっちもさっちもいかなくなったらSOS出してもらえれば、お手伝いはできる。 (ぶらっと) ---- これからしばらく外出するので、コード案をアップしておくね。処理の部品としては、↑でコメントしたような手法を使っているけど、大きな構成としてはマクロブックを独立させ、マクロの中で、元ブックを選択、それを担当別に分解という構えにしてある。元ブックの該当シート名や、分解したブックの保存フォルダパスについては、★をつけたところを実際のものに変更してね。（コードでは、元ブックと同じ場所に分解したブックを保存） Sub Sample() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim i As Long Dim myPath As String Dim fName As String 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン Application.ScreenUpdating = False Set wSh = ThisWorkbook.Sheets(1) 'マクロブックの作業シート wSh.Cells.Clear Set fSh = Workbooks.Open(ff).Sheets("Sheet1") '★基ブックの対象シート名は実際のものに myPath = fSh.Parent.Path & "¥" '★分解したブックの保存フォルダパス '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '新規ブック生成 fSh.Copy Set tSh = ActiveSheet tSh.Range("A1", tSh.UsedRange).Offset(3).ClearContents 'ユニークな担当者リストの作成 fList.Columns("Q:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wSh.Range("A1"), Unique:=True 'フィルターオプション検索条件欄のタイトル行作成 wSh.Range("D1:E1").Value = wSh.Range("A1:B1").Value wSh.Range("D2:E2").NumberFormatLocal = "@" 'ユニークな担当者リストから担当者を取り出しフィルターオプション実行 For i = 2 To wSh.Range("A1").CurrentRegion.Rows.Count '検索条件セット wSh.Range("D2:E2").Value = wSh.Range("A" & i).Resize(, 2).Value fName = wSh.Range("D2").Value & wSh.Range("E2").Value & "ファイル.xls" 'フィルターオプション実行 fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Range("D1").CurrentRegion, CopyToRange:=tSh.Range("A4"), Unique:=False '抽出されたものを、それぞれのブック名で保存（同名ブックがあれば無条件上書き） Application.DisplayAlerts = False tSh.Parent.SaveAs myPath & fName Application.DisplayAlerts = True Next 'あとしまつ fSh.Parent.Close False tSh.Parent.Close False wSh.Cells.Clear ThisWorkbook.Saved = True Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさんご教示頂きまして有難うございます。早速コード案を使用させて頂きましたところ、ファイル名は担当者別になっているのですが、ファイルを開けてみると、担当者と社員が全く同じ方のみの抽出になっているようです。ファイルにより社員ID（A列）だけ担当者別に表示されているようです。修正方法をご教示頂けいないでしょうか。マクロのイメージとしましては、（複数の）マクロ用のファイルを作成しており、そのファイルの中で担当者別にファイルを作成を行いたいと考えています。上から担当者別に処理するようなイメージです。折角コード案を作ってくださったのに言葉が足らず申し訳ありません。自分なりに色々試してみたのですが、ループがうまくできないです。 Sub Sample2() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim i As Long Dim myPath As String Dim fName As String Application.ScreenUpdating = False Set wSh = Worksheets.Add Set fSh = Sheets("○○") '★基ブックの対象シート名は実際のものに myPath = "C:¥Users¥○○¥Desktop¥○○¥" '★分解したブックの保存フォルダパス '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '新規ブック生成 fSh.Copy Set tSh = ActiveSheet tSh.Range("A1", tSh.UsedRange).Offset(3).ClearContents 'ユニークな担当者リストの作成 fList.Columns("Q:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wSh.Range("A1"), Unique:=True 'フィルターオプション検索条件欄のタイトル行作成 wSh.Range("D1:E1").Value = wSh.Range("A1:B1").Value wSh.Range("D2:E2").NumberFormatLocal = "@" 'ユニークな担当者リストから担当者を取り出しフィルターオプション実行 For i = 2 To wSh.Range("A1").CurrentRegion.Rows.Count '検索条件セット wSh.Range("D2:E2").Value = wSh.Range("A" & i).Resize(, 2).Value fName = fSh.Range("A1").Value & wSh.Range("D2").Value & wSh.Range("E2").Value & "さん" & ".xls" 'フィルターオプション実行 fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Range("D1").CurrentRegion, CopyToRange:=tSh.Range("A4"), Unique:=False '抽出されたものを、それぞれのブック名で保存（同名ブックがあれば無条件上書き） Application.DisplayAlerts = False tSh.Parent.SaveAs myPath & fName Application.DisplayAlerts = True Next ActiveWindow.Close 'あとしまつ Application.DisplayAlerts = False wSh.Delete Application.DisplayAlerts = True Sheets("○○").Select Range("A30").Select ActiveWorkbook.Save Application.ScreenUpdating = True MsgBox "Sample2を作成しました" End Sub （はな） ---- ごめん、ごめん。こちらがアップした Sample でいうと、上の方にある tSh.Range("A1", tSh.UsedRange).Offset(3).ClearContents この場所が悪かった。 fName = wSh.Range("D2").Value & wSh.Range("E2").Value & "ファイル.xls" この下に移動してくれる・さて、そちらでチューニングしたコードだけど、いったん、それは忘れて、新規ブックの標準モジュールに Sample を貼り付け実行してみてくれないかな? そちらでチューニングした Sample2。意図がわかりそうで、でも、ちょっと悩んでしまうチューニングもあって・・・とにかく、Sampleベースでやってみて、で、それに、そちらの改訂要件をチューニングしよう。（必要なら）たぶん、元ブックをマクロブックにしたいんだろうけど、コメントしたように、マクロブックを独立させた方が絶対にいいので。 (ぶらっと) ---- 追申とにかく、だまされたとおもって、とりあえず、Sampleベース（↑で連絡したクリアのコードの場所移動したもの）で試してね。各ブックのフォルダ関連、最終的にチューニングしよう。それまでは、とにかく現在の形でやってほしい。特に、分解したものをデスクトップ上のフォルダに保存するんだろうけど、このフォルダーパス、 XP と WIn7 では、異なる。 XP マシーンが手元になくなったけど、記憶によれば "C:¥Users¥○○¥Desktop¥○○¥" だと XP ではエラーになるような感じが・・・そのあたりも、最終的にチューニングしよう。各フォルダ（基ブック、分解したブック）が、どこにある、どんな名前なのかを教えてくれる? (ぶらっと) ---- ぶらっとさんご指示頂いた通りマクロは独立したファイルを作成し、実行したところ希望通りのファイルを作成することができました。有難うございました。大変助かりました。お問い合わせの件ですが、最終的には会社のネットワーク上のフォルダに保管する予定です。（今のところ会社のPCはXPでOfficeは2003です。今後はWIn7でOffice2010になるようです。）現在のファイル保管場所は、基ブック:デスクトップ、分解したファイル:デスクトップに「担当者別」というフォルダ名にしています。（はな） ---- 元ブックをダイアログでの選択ではなく直接読込にしたコードを参考まで。 Sub Sample3() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim i As Long Dim myPath As String Dim fName As String Dim oPath As String Application.ScreenUpdating = False With CreateObject("Wscript.Shell") oPath = .specialfolders("Desktop") & "¥" '★元ブックのフォルダパス myPath = .specialfolders("Desktop") & "¥担当者別¥" '★分解したブックの保存フォルダパス End With Set wSh = ThisWorkbook.Sheets(1) 'マクロブックの作業シート wSh.Cells.Clear Set fSh = Workbooks.Open(oPath & "¥元ブック.xls").Sheets("Sheet1") '★基ブックの名前と対象シート名は実際のものに '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '新規ブック生成 fSh.Copy Set tSh = ActiveSheet 'ユニークな担当者リストの作成 fList.Columns("Q:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wSh.Range("A1"), Unique:=True 'フィルターオプション検索条件欄のタイトル行作成 wSh.Range("D1:E1").Value = wSh.Range("A1:B1").Value wSh.Range("D2:E2").NumberFormatLocal = "@" 'ユニークな担当者リストから担当者を取り出しフィルターオプション実行 For i = 2 To wSh.Range("A1").CurrentRegion.Rows.Count '検索条件セット wSh.Range("D2:E2").Value = wSh.Range("A" & i).Resize(, 2).Value fName = wSh.Range("D2").Value & wSh.Range("E2").Value & "ファイル.xls" tSh.Range("A1", tSh.UsedRange).Offset(3).ClearContents 'フィルターオプション実行 fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Range("D1").CurrentRegion, CopyToRange:=tSh.Range("A4"), Unique:=False '抽出されたものを、それぞれのブック名で保存（同名ブックがあれば無条件上書き） Application.DisplayAlerts = False tSh.Parent.SaveAs myPath & fName Application.DisplayAlerts = True Next 'あとしまつ fSh.Parent.Close False tSh.Parent.Close False wSh.Cells.Clear ThisWorkbook.Saved = True Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさん修正コード有難うございます。早速試してみたところ、私の入力違いでエラーが表示されます。何度もお手数をお掛けいたしますがご教示いただけますでしょうか。 With CreateObject("Wscript.Shell") oPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥個別ファイル作成" '★元ブックのフォルダパス myPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥" '★分解したブックの保存フォルダパス End With Set wSh = ThisWorkbook.Sheets(1) 'マクロブックの作業シート wSh.Cells.Clear Set fSh = Workbooks.Open(oPath & "¥個別ファイル作成.xls").Sheets("個人用") 上のコードにくると、以下のエラーメッセージが表示されます。「'C:¥Users¥○○¥Desktop¥個別ファイル作成xls'が見つかりません。ファイル名およびファイルの保存場所が正しいかどうか確認してください。」（はな） ---- モバイルタブレットで書き込んでいるのでタイプミスあればご容赦まずこちらがアップしたコードにミスあり。デスクトップパスの最後に円マークをセットしてるのに ブック名連結の際にも円マークをつけていた。お恥ずかしい。ともあれ、そちらのコードでは元ブックがデスクトップ上の個人用ファイル作成というフォルダにあるということだけど、そうなの? ぶらっと ---- ぶらっとさん返信が大変遅くなってしまって申し訳ありません。個人用ファイル作成というファイル名のエクセルブックです。自宅では暫定で保管場所を決めています。最終的には会社のネットワークのフォルダに保管予定です。 (はな) ---- いやぁ、・・・・コメントしているのは・今動かしている環境で、個別ファイル作成.xls は、デスクトップ上の【個別ファイル作成】というフォルダにあるの? ということなんだけど? （そちらのコードがそうなっているので）だから、デスクトップ上に、【個別ファイル作成】というフォルダがなかったらエラーになるのは当然だけど? (ぶらっと) ---- ぶらっとさんありがとうございます。ファイルは直下だったからエラーを起こしたんですね。簡単なこともわからず申し訳ありませんでした。確認します。ものすごく厚かましくて申し訳ないのですか、同じデータで、新しくファイルを作らず、担当別ごとにシートに名前をつけて振り分ける方法を教えて頂けないでしょうか。何卒よろしくお願いいたします。 (はな) ---- ぶらっとさんご指摘いただきました、 oPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥個別ファイル作成" を oPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥"に修正したところ、問題なくファイル作成をすることができました。大変助かりました。有難うございました。（はな） ---- とりあえず、うまくいったようでよかった。 >同じデータで、新しくファイルを作らず、 >担当別ごとにシートに名前をつけて振り分ける方法を教えて頂けないでしょうか。元ブックにシートとして追加したい? それとも、担当者別シートにわけた形の1つの新規ブックにしたい? 運用面も考えると後者のほうがいいと思うけど。 (ぶらっと) ---- ぶらっとさんおかげさまで上手くいきました。有難うございました。お問い合わせの件ですが、担当別シートにわけた形の1つの新規ブックにしたいと考えています。大変お手数をおかけいたしますがよろしくお願い致します。（はな） ---- 元ブックも、新規ブックも同じフォルダのようなので、oPath、myPathの区別をやめて myPath一本で。元ブックと同じフォルダに元ブック_担当者別というブック名で。各シート名は 6666○○ とか。 Sub Sample4() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim i As Long Dim myPath As String Dim fName As String Dim sName As String Dim done As Boolean Dim d As Variant Application.ScreenUpdating = False myPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥" '★元ブック、分解したブックのフォルダパス Set wSh = ThisWorkbook.Sheets(1) 'マクロブックの作業シート wSh.Cells.Clear Set fSh = Workbooks.Open(myPath & "元ブック.xls").Sheets("Sheet1") '★元ブックの名前と対象シート名は実際のものに '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") 'ユニークな担当者リストの作成 fList.Columns("Q:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wSh.Range("A1"), Unique:=True 'フィルターオプション検索条件欄のタイトル行作成 wSh.Range("D1:E1").Value = wSh.Range("A1:B1").Value wSh.Range("D2:E2").NumberFormatLocal = "@" 'ユニークな担当者リストから担当者を取り出しフィルターオプション実行 For i = 2 To wSh.Range("A1").CurrentRegion.Rows.Count '検索条件セット wSh.Range("D2:E2").Value = wSh.Range("A" & i).Resize(, 2).Value sName = wSh.Range("D2").Value & wSh.Range("E2").Value If done Then fSh.Copy After:=tSh Else done = True '新規ブック生成 fSh.Copy End If Set tSh = ActiveSheet tSh.Name = sName tSh.Range("A1", tSh.UsedRange).Offset(3).ClearContents 'フィルターオプション実行 fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Range("D1").CurrentRegion, CopyToRange:=tSh.Range("A4"), Unique:=False Next '新規ブックを保存（同名ブックがあれば無条件上書き） d = Split(fSh.Parent.Name, ".") fName = d(0) & "_担当者別." & d(1) Application.DisplayAlerts = False tSh.Parent.SaveAs myPath & fName Application.DisplayAlerts = True 'あとしまつ fSh.Parent.Close False tSh.Parent.Close False wSh.Cells.Clear ThisWorkbook.Saved = True Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさんご教示頂きまして有難うございました。一瞬で処理が完了して感動しました。別ファイルに移行するということをご推奨頂きましたので、教えて頂いたマクロコードのみ保存されているファイルに保管します。この期に及んで厚かましく大変申し訳ございませんがもう少しお付き合い頂けませんでしょうか。あとひとつマクロ処理をしていまして、この機会に一緒に保管できれば今後の業務改善となりますのでご教示頂きたく何卒宜しくお願い致します。元データのO列に「○」が付いている箇所を対象として別シートのテンプレートに一部転記し、シートの保護をかけ、新規ファイルを作成するというマクロ処理です。【元データ】（前回ご教示頂いたファイル・シートともに同じです。） シート名【個人用】タイトル等A1〜T4 A B ・・ E ・G ・・ K L M ・ O ・ Q R S T 4 社員ID 社員名所属事業所時間外合計 1か月前時間外 2カ月前時間外問診票対象者担当者ID 担当者名年齢性別 5 0000 あああ AA 1 100 80 90 ○ 6666 ○○ XX ○ 6 1111 いいい AA 1 62 48 50 6666 ○○ 7 2222 ううう BB 2 85 95 80 ○ 7777 ■■ XX ○ 8 3333 えええ CC 3 120 87 50 ○ 8888 △△ XX ○ 9 4444 おおお CC 3 62 48 50 8888 △△ ↓ シート名【問診用】（テンプレート） *時間外の時間を月別項目に転記するためInputBoxを設けています。（前月のみ月を入力するとvlookup関数で1・2ヵ月前の月が表示されるように計算式を入れています。）月 = InputBox("元データの「月」を入力してください例:（前月）○月 → ○") Range("BG30") = 月（セルの結合をすると上手くマクロが処理されないので、転記後セルを結合しています。。）【転記先セル】事業所("AJ15") 所属名("AJ18") 社員番号("DG15") 社員名("DG18") 年齢("DG21") 性別("DG24") 時間外合計("BG34") 1か月前時間外("CU34") 2か月前時間外("EF34") 【セルの結合】事業所("AJ15:CG17") 所属("AJ18:CG20") TEL("AJ21:CG23") e-mail("AJ24:CG26") 社員番号("DG15:FD17") 氏名("DG18:FD20") 年齢("DG21:FD23") 性別("DG24:FD26") 時間外実績("BG30:BP33") 時間外合計(h)("BG34:BS37") 1か月前時間外("CU34:DG37") 2か月前時間外("EF34:ER37") 問診票.Protect Password:="○○○" 【マクロ処理後】ファイル名: 問診票0000あああさん.xls タイトル等A1〜FM14 事業所 | 1 |社員番号 0000 所属 | AA |氏名あああ TEL | 空白 |年齢 XX e-mail| 空白 |性別 ○ 時間外| ○月 | ×月 | □月 | 100 | 80 | 90 | （はな） ---- >Range("BG30") = 月これは、どのシートの BG30 ? (ぶらっと) ---- ぶらっとさん早速見て頂いて有難うございます。 >Range("BG30") = 月こちらは、【問診用】です。（はな） ---- 了解。コードを書いてみるけど、それとは別に。 >セルの結合をすると上手くマクロが処理されないので、転記後セルを結合しています。。結合セルはやっかいだけど、かといって転記できないわけでもない。うまくいかないコードをサンプルとしてアップしてもらえないかな? 追記で。問診票側のセル結合だけど、おそろしく、横にたくさんの数のセルが結合されているね。たとえば、社員番号に対して、50セル!! 間違いないんだよね? もう1つ。これまでのものは担当者別に抽出しているけど、今回は、社員別だね。で、これまでのものは、元シートに同じ担当者データが複数あったけど、社員データは元シートにユニークに1行だけと考えていいのかな? (ぶらっと) ---- とりあえず書いてみた。仕様の勘違いあれば指摘乞う。なお、上でもコメントしたけど、こちらでは問診票テンプレートシートのセルを結合させていてそこに直接転記している。なので、新規ブックがわでは何もしていない。 Sub Sample5() Dim fSh As Worksheet Dim tSh As Worksheet Dim myPath As String Dim fName As String Dim mm As Long Dim c As Range Dim wb As Workbook mm = Application.InputBox("元データの「月」を入力してください" & vbLf & "例:（前月）○月 → ○", Type:=1) If mm = 0 Then Exit Sub 'キャンセルボタン If mm < 1 Or mm > 13 Then MsgBox "月は 1〜12 ですよ" Exit Sub End If Application.ScreenUpdating = False myPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥" '★元ブック、分解したブックのフォルダパス Set wb = Workbooks.Open(myPath & "元ブック.xls") '★元ブックの名前は実際のものに Set fSh = wb.Sheets("個人用") '★シート名は実際のものに Set tSh = wb.Sheets("問診票") '★シート名は実際のものに fSh.Range("BG30").Value = mm For Each c In fSh.Range("A5", fSh.Range("A" & fSh.Rows.Count).End(xlUp)) With c.EntireRow If .Range("O1").Value = "○" Then '問診票対象 tSh.Range("AJ15").Value = .Range("G1").Value '事業所 tSh.Range("AJ18").Value = .Range("E1").Value '所属 tSh.Range("DG15").Value = .Range("A1").Value '社員ID tSh.Range("DG18").Value = .Range("B1").Value '社員名 tSh.Range("DG21").Value = .Range("S1").Value '年齢 tSh.Range("DG24").Value = .Range("T1").Value '性別 tSh.Range("BG34").Value = .Range("K1").Value '時間外合計 tSh.Range("CU34").Value = .Range("L1").Value '1か月前時間外 tSh.Range("EF34").Value = .Range("M1").Value '2か月前時間外 fName = "問診票" & .Range("A1").Value & .Range("B1").Value & ".xls" tSh.Copy '新規ブック Application.DisplayAlerts = False '同名ブックがあれば無条件上書き With ActiveWorkbook .SaveAs myPath & fName, Password:="abcdefg" .Close End With End If End With Next wb.Close False '元ブックを閉じる Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさん早速ご教示頂きまして有難うございます。 > 問診票側のセル結合だけど、おそろしく、横にたくさんの数のセルが結合されているね。 > たとえば、社員番号に対して、50セル!! > 間違いないんだよね? はい。50セルあります。転記データの下に問診票のチェックリスト作成しています。そのためセルを細かくしなければならなかったため、サイの目状にシートを加工しています。 >これまでのものは担当者別に抽出しているけど、今回は、社員別だね。はい。前回までは担当者別での抽出でしたが、今回はO列の問診票対象者の「○」のフラグがある人を抽出し、順にテンプレートに転記するというものです。 >で、これまでのものは、元シートに同じ担当者データが複数あったけど、社員データは >元シートにユニークに1行だけと考えていいのかな? はい。社員データは、複数いないので、1行だけです。私の作ったサンプルは記録マクロのようなコードですので、大変見づらいと思いますがよろしくお願い致します。（概要）個人用シートから問診票対象者の「○」のフラグがある人を抽出し、新規シートにデータを転記し、さらにテンプレートにデータを転記しています。見なおしてみるとすごい方法でコードを作っていますね。。本当に見づらくて申し訳ありません。 Sub Sample00() Dim 行 As Integer Dim 月 As String Dim メール行 As Integer Dim 個人送付用 As String Dim 事業所 As String Dim 所属 As String Dim 社員番号 As String Dim 社員名 As String Dim 氏名 As Variant Dim 年齢 As Variant Dim 性別 As Variant Dim 時間外実績 As String Dim 時間外合計 As String Dim 1か月前時間外 As String Dim 2か月前時間外 As String Dim 問診票 As Worksheet Application.ScreenUpdating = False Sheets("問診用").Select 月 = InputBox("元データの「月」を入力してください例:（前月）○月 → ○") Range("BG30") = 月 Sheets("個人用").Select Columns("R:R").Select Selection.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A4").Select Selection.AutoFilter Selection.AutoFilter Field:=15, Criteria1:="○" Worksheets.Add '【個人用Sheetの問診票対象者を新規Sheetに転記する】 '事業所貼付 Sheets("個人用").Select Range("G4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("A1").Select ActiveSheet.Paste '所属貼付 Sheets("個人用").Select Range("E4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("B1").Select ActiveSheet.Paste '社員番号貼付 Sheets("個人用").Select Range("A4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("C1").Select ActiveSheet.Paste '氏名貼付 Sheets("個人用").Select Range("B4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D1").Select ActiveSheet.Paste Selection.Replace What:=" ", Replacement:=" " '年齢貼付 Sheets("個人用").Select Range("S4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("E1").Select ActiveSheet.Paste '性別貼付 Sheets("個人用").Select Range("T4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("F1").Select ActiveSheet.Paste '時間外合計貼付 Sheets("個人用").Select Range("K4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("G1").Select ActiveSheet.Paste '1か月前時間外貼付 Sheets("個人用").Select Range("L4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("H1").Select ActiveSheet.Paste '2か月前時間外貼付 Sheets("個人用").Select Range("M4").Select Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("I1").Select ActiveSheet.Paste 'ファイル保存用 Range("D1").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Range("J1").Select ActiveSheet.Paste Application.CutCopyMode = False '問診票に転記 Sheets("Sheet1").Select 行 = 2 メール行 = 2 Do Until Cells(行, 2).Value = "" '【新規Sheetから問診用Sheetへの転記】出力処理: 事業所 = Cells(行, 1).Value 所属 = Cells(行, 2).Value 社員番号 = Cells(行, 3).Value 社員名 = Cells(行, 4).Value 年齢 = Cells(行, 5).Value 性別 = Cells(行, 6).Value 時間外合計 = Cells(行, 7).Value 1か月前時間外 = Cells(行, 8).Value 2か月前時間外 = Cells(行, 9).Value Sheets("問診票").Select Range("AJ15").Select Cells(15, "AJ").Value = 事業所 Cells(18, "AJ").Value = 所属 Cells(15, "DG").Value = 社員番号 Cells(18, "DG").Value = 社員名 Cells(21, "DG").Value = 年齢 Cells(24, "DG").Value = 性別 Cells(34, "BG").Value = 時間外合計 Cells(34, "CU").Value = 1か月前時間外 Cells(34, "EF").Value = 2か月前時間外 '体裁（セルの結合） '事業所 Range("AJ15:CG17").MergeCells = True Application.DisplayAlerts = False '所属 Range("AJ18:CG20").MergeCells = True Application.DisplayAlerts = False 'TEL Range("AJ21:CG23").MergeCells = True Application.DisplayAlerts = False Range("AJ21:CG23").Select Selection.Locked = False Selection.FormulaHidden = False With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With 'e-mail Range("AJ24:CG26").MergeCells = True Application.DisplayAlerts = False Range("AJ24:CG26").Select Selection.Locked = False Selection.FormulaHidden = False With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With '社員番号 Range("DG15:FD17").MergeCells = True Application.DisplayAlerts = False With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With '氏名 Range("DG18:FD20").MergeCells = True Application.DisplayAlerts = False '年齢 Range("DG21:FD23").MergeCells = True Application.DisplayAlerts = False With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With '性別 Range("DG24:FD26").MergeCells = True Application.DisplayAlerts = False '時間外実績 Range("BG30:BP33").MergeCells = True Application.DisplayAlerts = False '時間外合計(h) Range("BG34:BS37").MergeCells = True Application.DisplayAlerts = False HorizontalAlignment = xlCenter '1か月前時間外 Range("CU34:DG37").MergeCells = True Application.DisplayAlerts = False HorizontalAlignment = xlCenter '2か月前時間外 Range("EF34:ER37").MergeCells = True Application.DisplayAlerts = False HorizontalAlignment = xlCenter Range("DG15:FD17").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Range("DG21:FD23").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Range("AJ24:CG26").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With '個別ファイル作成 Sheets("問診票").Select Sheets("問診票").Copy ActiveWindow.View = xlPageBreakPreview 氏名 = Cells(18, "DG") 社員番号 = Cells(15, "DG") ActiveWorkbook.SaveAs Filename:="¥ネットワークのフォルダ¥個人送付用¥" & ("問診票" & "(" & 社員番号 & " " & 氏名 & "さん" & ")") & ".xls" Set 問診票 = Worksheets(1) 問診票.Protect Password:="○○○" ActiveWorkbook.Save ActiveWindow.Close メール行 = メール行 + 1 Sheets("Sheet1").Select 行の終わり: 行 = 行 + 1 Loop '元のフォームへ戻す '@Sheet1の削除 Windows("個別ファイル作成.xls").Activate Sheets("Sheet1").Select ActiveWindow.SelectedSheets.Delete 'A個人用Sheetのオートフィルタ解除 Sheets("個人用").Select Selection.AutoFilter Range("A4").Select 'B問診票のデータ削除 Sheets("問診票").Select Range( _ "AJ15:CG26,DG15:FD26,BG30:BP33,BG34:BS37,CU34:DG37,EF34:ER37").Select Selection.ClearContents Selection.UnMerge Range("AJ15").Select Sheets("ファイル作成").Select Range("A30").Select ActiveWorkbook.Save Application.ScreenUpdating = True MsgBox "個人用を作成しました" End Sub （はな） ---- そちらのコードは、まだ精読していないけど、ざっと見た感じではマクロ記録でできあがった部品をしっかりと構成し直してまとまっているんじゃないかなと思う。ただ、マクロ記録の宿命というか、人間の操作をそのままコード化しているので、何かを選択する（Select)-->選択した何か（Selection）に対して何かを行う。この操作から、○○.Select --> Selection.■■ というペアがてんこ盛りになる。このコードは ○○.■■ とまとめてかけるし、そう書くことが推奨されているね。また、マクロ記録で値の転記を行うと、どうしてもコピー・ペースト系のコードが生成される。値の転記は、これまで、こちらがアップしたコードにあるように、転記先セル.Value = 転記元セル.Value と書くことができるし、この書き方をすれば、結合セルでときおり発生する障害は発生しない。あぁ、それと、結合セル.ClearContents これはエラーになるけど結合セル.Value = "" とすると、エラー無く処理可能。いずれにしても、元ブックの問診票テンプレートシートのセルを結合した上でこちらがアップした Sample5 を試してみてくれるかな? (ぶらっと) ---- ぶらっとさんご回答有難うございます。全くわからない状況で色々ご教示頂きまして有難うございます。今後VBAを勉強していく上で参考にさせて頂きます。ご指示頂きましたとおり、セルを結合してからマクロを実行したところ無事にファイルを作成することが出来ました。有難うございました。作成頂きましたコードで2点ご教示頂けますでしょうか。何度も申し訳ございません。 >myPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥" ファイルの保存場所を「担当者別」フォルダではなく、別フォルダの「個人送付用」というフォルダに保管させるにはどのようにすればいいでしょうか。 >.SaveAs myPath & fName, Password:="abcdefg" ファイルを保存する際にシート保護をかけるにはどうのようにしたらよろしいでしょうか。説明の際に言葉足らずで申し訳ありません。（はな） ---- >ファイルを保存する際にシート保護をかけるにはどうのようにしたらよろしいでしょうかあっ、そうか。保護はブックじゃなくシートだったんだね。ごめん。 >別フォルダの「個人送付用」というフォルダに保管させるにはどのようにすればいいでしょうか。 Sample5 では、ともに同じフォルダだと思ったんだけど、別々のフォルダということなら元フォルダとは別に保存フォルダを定義して、SaveAs で、それを使おう。ということで。 Dim svPath As String こんな定義を追加しておいて myPath = CreateObject("Wscript.Shell").specialfolders("Desktop") & "¥担当者別¥" これを With CreateObject("Wscript.Shell") myPath = .specialfolders("Desktop") & "¥担当者別¥" svPath = .specialfolders("Desktop") & "¥個人送付用¥" End With で、tSh.Copy '新規ブック の下に ActiveSheet.Protect Password:="abcdefg" を追加。（注）あと、.SaveAs myPath & fName, Password:="abcdefg" を .SaveAs svPath & fName に。（注）シート保護を掛ける際に、操作者に許可する操作にチェックをつけるよね。 ↑のProtect は、それらが【規定値】の設定になる。これは許可したいというものが規定値以外にあればそれらを引数で指定必要。ついでに。 シート保護は、手っ取り早く、元のテンプレートシートには保護がかかっておらず、新規に作ったものに保護をかける方式にしたけど、以下のようなこともできる。ご参考まで。 1）もし、コードでセットしているセルが、新規ブック側でも、入力可能セルなら、元ブックのテンプレート側に シート保護をかけておいて、マクロでは、シート保護に関しては何もしない。（ただ、今回の要件では、コードでセットしているセルは新規ブックでは、入力不可だと思うので、この方式はNGだね） 2）元ブックのテンプレート側をシート保護しておき、・新規ブックとして生成した後、マクロ内で非保護にして、セルに値をセットして、その後マクロ内でシート保護に戻す。・あるいは、マクロ内でセルに値をセットする前に、操作者は操作できないけどマクロでの書き込み等はできるような「おまじない」をコードに書く。 (ぶらっと) ---- ぶらっとさん無事に動作しました。 シート保護に関しましては入力箇所のみロックを外した状態でマクロで保護をかけたところ、うまくいきました。有難うございました!! 今日、会社でマクロを動かしデスクトップで作業すると申し上げたのですが、やはり、今後のことを考えるとファイルを選択をしてからネットワーク上のフォルダに保存する方法が良さそうです。。。自分で加工しようと思いましたが、マクロを動かすとマクロのみのエクセルファイルに担当者のデータがコピーされてしまい、保存がうまくできませんでした。ご教示頂けると大変助かります。御願いばかりで申し訳ございません。（はな） ---- >やはり、今後のことを考えるとファイルを選択をしてからネットワーク上のフォルダに保存する方法が良さそうです。。。・ファイルを選択してから・・・というのが、最初に元ブックを操作者がダイアログから指定して開くということであれば一番最初にアップしたコードのあるように、 Dim ff As Variant といったものを追加しておきプロシジャの最初に 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタンこのようなコードを書く。で、 Set wb = Workbooks.Open(myPath & "元ブック.xls") '★元ブックの名前は実際のものにこれを Set wb = Workbooks.Open(ff) '★元ブックの名前は実際のものに・ネットワーク上のフォルダに保存するこれが、最後の保存フォルダのことであれば svPath = "¥¥○○○¥■■■¥" といったように、ネットワークフォルダパスを指定しておくだけでいいよ。この保存フォルダも、操作者にダイアログで指定させる方法もあるけど。 (ぶらっと) ---- ぶらっとさんご指示のとおりコードを修正しましたらネットワーク上に保存することが出来ました。有難うございます。コードを修正いただいたことで、いくつか不便な点が出てきました。ご教示頂けないでしょうか。ファイルを指定しても、元データのファイルにテンプレートが存在しませんので、できればマクロコードが入っているファイルにテンプレートを置いて、分解貼付作業をしたいと考えています。可能でしょうか。 >この保存フォルダも、操作者にダイアログで指定させる方法もあるけど。はい。そのようにお願いしたいです。毎回大変お手数をおかけいたしますがよろしくお願いいたします。（はな） ---- フォルダの選択はいろんな方法があるけど、わりあいとわかりやすいものを使った。コードを書いただけでテストしていないので、不具合あれば指摘乞う。 Sub Sample6() Dim fSh As Worksheet Dim tSh As Worksheet Dim fName As String Dim mm As Long Dim c As Range Dim wb As Workbook Dim svPath As String Dim ff As Variant Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 mm = Application.InputBox("元データの「月」を入力してください" & vbLf & "例:（前月）○月 → ○", Type:=1) If mm = 0 Then Exit Sub 'キャンセルボタン If mm < 1 Or mm > 13 Then MsgBox "月は 1〜12 ですよ" Exit Sub End If 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '★シート名は実際のものに Set tSh = ThisWorkbook.Sheets("問診票") '★シート名は実際のものに fSh.Range("BG30").Value = mm For Each c In fSh.Range("A5", fSh.Range("A" & fSh.Rows.Count).End(xlUp)) With c.EntireRow If .Range("O1").Value = "○" Then '問診票対象 tSh.Range("AJ15").Value = .Range("G1").Value '事業所 tSh.Range("AJ18").Value = .Range("E1").Value '所属 tSh.Range("DG15").Value = .Range("A1").Value '社員ID tSh.Range("DG18").Value = .Range("B1").Value '社員名 tSh.Range("DG21").Value = .Range("S1").Value '年齢 tSh.Range("DG24").Value = .Range("T1").Value '性別 tSh.Range("BG34").Value = .Range("K1").Value '時間外合計 tSh.Range("CU34").Value = .Range("L1").Value '1か月前時間外 tSh.Range("EF34").Value = .Range("M1").Value '2か月前時間外 fName = "問診票" & .Range("A1").Value & .Range("B1").Value & ".xls" tSh.Copy '新規ブック ActiveSheet.Protect Password:="abcdefg" Application.DisplayAlerts = False '同名ブックがあれば無条件上書き With ActiveWorkbook .SaveAs svPath & fName .Close End With End If End With Next wb.Close False '元ブックを閉じる 'マクロブックのテンプレートの項目セット領域をクリア tSh.Range("AJ15").Value = "" '事業所 tSh.Range("AJ18").Value = "" '所属 tSh.Range("DG15").Value = "" '社員ID tSh.Range("DG18").Value = "" '社員名 tSh.Range("DG21").Value = "" '年齢 tSh.Range("DG24").Value = "" '性別 tSh.Range("BG34").Value = "" '時間外合計 tSh.Range("CU34").Value = "" '1か月前時間外 tSh.Range("EF34").Value = "" '2か月前時間外 Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさん返信が大変遅くなり申し訳ございません。ご教示頂きましたコードを実行したところ問題なく処理が出来ました。有難うございました。大変助かりました。以前にもう1つだけと申し上げましたが、大変申し訳ございません。全部で3つ（2つはご教示頂きました）のマクロコードを作成しており、最後の1つがコード作成が大変難しく手を焼いております。もし宜しければご教示頂けないでしょうか。何卒宜しくお願い致します。【概要】元データのO列に「○」が付いている社員かつE列の所属別かつQ列の担当者別に別シートのテンプレートに一部転記し、新規ファイルを作成するというマクロ処理です。 シート名【個人用】（前回ご教示頂いたファイル・シートともに同じです。）タイトル等A1〜T4 A B ・・ E ・・・・ O ・ Q R 4 社員ID 社員名所属問診票対象者担当者ID 担当者名 5 0000 あああ AA ○ 6666 ○○ 6 1111 いいい AA ○ 6666 ○○ 7 2222 ううう BB 7777 ■■ 8 3333 えええ CC ○ 8888 △△ 9 4444 おおお CC 8888 △△ ↓ シート名【計画書】（テンプレート）【マクロ処理後】ファイル名: 計画書0000あああさん.xls 所属 | AA | 該当者 | ‘@0000 あああ ‘C ‘F ‘A1111 いいい ‘D ‘G ‘B ‘E ‘H 色々要望を申し上げて申し訳ございません。丸枠番号順に社員IDと社員名を転記できることが理想的です。完成には程遠いですが、ご教示頂いた箇所を引用しコードを作成致しましたがこれ以上は力不足で先に進めなくなっております。最終的には3つのマクロを通しで実行できるように考えております。ご教示頂けると大変助かります。何卒宜しくお願い致します。 Sub sample_計画書() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim c As Range Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '★シート名は実際のものに Set tSh = ThisWorkbook.Sheets("計画書") '★シート名は実際のものに '禁則記号置換 Columns("E:E").Select Selection.Replace What:="/", Replacement:="_" 'ユニークな担当者リストから担当者を取り出しフィルターオプション実行 For Each c In fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)) With c.EntireRow If .Range("O1").Value = "○" Then '問診票対象 '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") 'ユニークな担当者リストの作成 fList.Columns("Q:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wSh.Range("A1"), Unique:=True 'フィルターオプション検索条件欄のタイトル行作成 wSh.Range("D1:E1").Value = wSh.Range("A1:B1").Value wSh.Range("D2:E2").NumberFormatLocal = "@" tSh.Range("AG18").Value = .Range("G1").Value '事業所名 tSh.Range("AG22").Value = .Range("A1").Value '社員番号@ tSh.Range("AR22").Value = .Range("B1").Value '社員名@ tSh.Range("AG25").Value = .Range("A2").Value '社員番号A tSh.Range("AR25").Value = .Range("B2").Value '社員名A tSh.Range("AG28").Value = .Range("A3").Value '社員番号B tSh.Range("AR28").Value = .Range("B3").Value '社員名B tSh.Range("BN22").Value = .Range("A4").Value '社員番号C tSh.Range("BX22").Value = .Range("B4").Value '社員名C tSh.Range("BN25").Value = .Range("A5").Value '社員番号D tSh.Range("BX25").Value = .Range("B5").Value '社員名D tSh.Range("BN28").Value = .Range("A6").Value '社員番号E tSh.Range("BX28").Value = .Range("B6").Value '社員名E tSh.Range("CR22").Value = .Range("A7").Value '社員番号F tSh.Range("DD22").Value = .Range("B7").Value '社員名F tSh.Range("CR25").Value = .Range("A8").Value '社員番号G tSh.Range("DD25").Value = .Range("B8").Value '社員名G tSh.Range("CR22").Value = .Range("A9").Value '社員番号H tSh.Range("DD28").Value = .Range("B9").Value '社員名H tSh.Range("DX22").Value = .Range("A10").Value '社員番号I tSh.Range("EJ22").Value = .Range("B10").Value '社員名I tSh.Range("DX25").Value = .Range("A11").Value '社員番号J tSh.Range("EJ25").Value = .Range("B11").Value '社員名J tSh.Range("DX28").Value = .Range("A12").Value '社員番号K tSh.Range("EJ28").Value = .Range("B12").Value '社員名K fName = "計画書" & .Range("Q2").Value & .Range("R2").Value & "さん" & ".xlsx" tSh.Copy '新規ブック Application.DisplayAlerts = False '同名ブックがあれば無条件上書き With ActiveWorkbook .SaveAs svPath & fName .Close End With End If End With Next wb.Close False '元ブックを閉じる 'マクロブックのテンプレートの項目セット領域をクリア tSh.Range("AG18").Value = "" '事業所名 tSh.Range("AG22").Value = "" '社員番号@ tSh.Range("AR22").Value = "" '社員名@ tSh.Range("AG25").Value = "" '社員番号A tSh.Range("AR25").Value = "" '社員名A tSh.Range("AG28").Value = "" '社員番号B tSh.Range("AR28").Value = "" '社員名B tSh.Range("BN22").Value = "" '社員番号C tSh.Range("BX22").Value = "" '社員名C 'tSh.Range("BN25").Value = "" '社員番号D 'tSh.Range("BX25").Value = "" '社員名D 'tSh.Range("BN28").Value = "" '社員番号E 'tSh.Range("BX28").Value = "" '社員名E 'tSh.Range("CR22").Value = "" '社員番号F 'tSh.Range("DD22").Value = "" '社員名F 'tSh.Range("CR25").Value = "" '社員番号G 'tSh.Range("DD25").Value = "" '社員名G 'tSh.Range("CR22").Value = "" '社員番号H 'tSh.Range("DD28").Value = "" '社員名H 'tSh.Range("DX22").Value = "" '社員番号I 'tSh.Range("EJ22").Value = "" '社員名I 'tSh.Range("DX25").Value = "" '社員番号J 'tSh.Range("EJ25").Value = "" '社員名J 'tSh.Range("DX28").Value = "" '社員番号K 'tSh.Range("EJ28").Value = "" '社員名K Application.ScreenUpdating = True MsgBox "分解・保存完了" （はな） ---- コードを読めば要件がわかるのかもしれないけど、説明文だけを読んだレベルでの質問。できあがるブック名が計画書0000あああさん.xls だとすると、A列、B列でまとめる（社員番号と名前）のように思えるけどできあがりイメージの例では、中味として 0000 あああ、1111 いいいがあるね? 1111 いいいも計画書0000あああさん.xls の対象になるの?? ちょっとわからないなぁ・・・ AA6666.xls なら、わかるけど・・・・ (ぶらっと) ---- ぶらっとさん早速ご覧頂きましてありがとうございます。申し訳ありません。ご指摘の通りで入力間違いをしておりました。ファイル名は 6666〇〇さん.xls で、該当者は、「0000あああ」と「1111いいい」です。大変お手数をお掛け致しますがよろしくお願いいたします。 (はな) ---- 6666さんに対して AA BB といったように複数登場するとどうする? (ぶらっと) ---- ぶらっとさんできれば別ブックで出力したいです。抽出条件に追加しなければいけなかったですね。申し訳ありません。 (はな) ---- 要件を誤解している可能性もあるけど、とにかく試してみて。マクロブック内の作業シートを使用。コードでは "Sheet1" にしてある。計画書シートへのセット位置やセット要領も不明なので、コードの初めのほうの Const stRow As Long = 2 '★計画書の最初の社員IDの行番号 Const stCol As Long = 2 '★計画書の最初の社員IDの列番号(B列） Const colRows As Long = 3 '★計画書の1列のセット行数 Const setCols As Long = 2 '★計画書にセットする1データあたりの列数これらで、規定している。実態と異なれば、ここを変更。なお、所属別にブックをわけるということなので、ブック名は計画書AA_6666〇〇さん.xlsx にしてある。 Sub sample7() Const stRow As Long = 2 '★計画書の最初の社員IDの行番号 Const stCol As Long = 2 '★計画書の最初の社員IDの列番号(B列） Const colRows As Long = 3 '★計画書の1列のセット行数 Const setCols As Long = 2 '★計画書にセットする1データあたりの列数 Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim c As Range Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Dim svPath As String Dim dic As Object Dim w1 As Long Dim w2 As Long Dim w3 As Long Dim r As Range Dim x As Long Dim y As Long Dim i As Long Dim j As Long Dim v() As Variant Dim base As Range Dim id As Variant Dim nm As Variant Dim sz As Variant 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '元ブックの一覧シート ThisWorkbook.Sheets("計画書").Copy 'マクロ内テンプレートから新規ブックを生成 Set tSh = ActiveSheet Set base = tSh.Cells(stRow, stCol) '計画書のデータ領域の左上隅 Set wSh = ThisWorkbook.Sheets("Sheet1") '★マクロブック内作業シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" '★どのシートのE列なのかを明記した '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:T") '所属、担当者ID,担当者名の組み合わせのユニークなリストを作業シートに生成 wSh.Cells.ClearContents w1 = fList.Columns.Count + 2 w2 = w1 + 4 w3 = w2 + 4 fList.Columns("E").Copy wSh.Cells(1, w1) '所属 fList.Columns("Q").Copy wSh.Cells(1, w1 + 1) '担当者ID fList.Columns("R").Copy wSh.Cells(1, w1 + 2) '担当者名 wSh.Cells(1, w1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=wSh.Cells(1, w2), Unique:=True wSh.Cells(1, w3).Resize(, 3).Value = wSh.Cells(1, w1).Resize(, 3).Value wSh.Cells(1, w3 + 3).Value = fSh.Range("O4").Value '要否タイトル 'ユニークなリストから条件を取り出しフィルターオプション実行 With wSh.Cells(1, w2).CurrentRegion.Columns(1) For Each r In .Resize(.Rows.Count - 1).Offset(1).Cells wSh.Cells(2, w3).Resize(, 3).Value = r.Resize(, 3).Value wSh.Cells(2, w3 + 3).Value = "○" wSh.Columns("A").Resize(, fList.Columns.Count).ClearContents fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Cells(1, w3).CurrentRegion, _ CopyToRange:=wSh.Range("A1"), Unique:=False x = wSh.Range("A1").CurrentRegion.Rows.Count 'タイトル行含めた抽出行数 If x > 1 Then '抽出があれば sz = wSh.Cells(2, w3).Value '所属 id = wSh.Cells(2, w3 + 1).Value '担当者ID nm = wSh.Cells(2, w3 + 2).Value '担当者名 tSh.Range("A1", tSh.UsedRange).Offset(stRow - 1, stCol - 1).ClearContents '転記領域のクリア y = x ¥ setCols If x Mod setCols > 0 Then y = x + 1 '横展開数 ReDim v(1 To colRows, 1 To y * setCols) '転記用配列 i = 1 j = 1 '抽出したリストから対象データを配列に格納 For Each c In wSh.Range("A2", wSh.Range("A" & wSh.Rows.Count).End(xlUp)) v(i, j) = c.Value v(i, j + 1) = c.Offset(, 1).Value i = i + 1 If i = colRows + 1 Then j = j + setCols i = 1 End If Next tSh.Range("B1").Value = sz base.Resize(UBound(v, 1), UBound(v, 2)).Value = v fName = "計画書" & sz & "_" & id & nm & "さん" & ".xlsx" Application.DisplayAlerts = False '同名ブックがあれば無条件上書き tSh.Parent.SaveAs svPath & fName Application.DisplayAlerts = True End If Next End With wSh.Cells.Clear wb.Close False '元ブックを閉じる tSh.Parent.Close False '作成した新規ブックも閉じる Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさん返信が大変遅くなり申し訳ありません。マクロを実行してみたところ、下記のところでマクロが停まってしまいます。 Set wSh = ThisWorkbook.Sheets("Sheet1") '★マクロブック内作業シート 大変お手数をお掛けしますがご教示頂けますでしょうか。何卒よろしくお願いいたします。（はな） ---- 【ここで止まる】とか【ここでエラーになる】といったコメントをもらうたびにお願いすることだけど『どんな内容のエラーメッセージ』だったかが、レスするためには必須。こちらで『エラーが発生しないような環境』で、このコードを実行すると、あたりまえだけどエラーにはならないので。『インデックスが有効ではない』といったエラーだったのかな? コードをアップする際に『マクロブック内の作業シートを使用。コードでは "Sheet1" にしてある。』とコメントしたけど、マクロブックには "Sheet1"という名前のシートがある? (ぶらっと) ---- ぶらっとさん大変失礼しました。わかりくいご説明で申し訳ありませんでした。コードを見ながらF8でマクロを実行していたので特に何も表示されなかったと思います。 "Sheet1"というシートは存在しておりませんので、下記のように修正したところマクロが実行できました。 Set wSh = ThisWorkbook.Sheets("Sheet1") → Set wSh = ThisWorkbook.Sheets(1) 完成したファイルを開いてみると、大変申し訳ないです。説明に社員番号と社員名が別のセルになっていることをお伝えしておりませんでした。その結果、一番最初に転記される社員番号のみの表示となりました。どのように修正すればよろしいでしょうか。【レイアウト】所属 | AA | 担当者名 |※マクロ対象外です。計画書の最初の社員IDの行番号 22行目計画書の最初の社員IDの列番号 33列目社員番号社員名 ↓ ↓ 該当者 |@22行目/33列目|22行目/44列目|C（22行目/66列目|22行目/76列目|・・ |A25行目/33列目|25行目/44列目|D（25行目/66列目|25行目/76列目|・・ |B28行目/33列目|28行目/44列目|E（28行目/66列目|28行目/76列目|・・今、転記されているのは@の社員番号のみです。（はな） ---- 計画書シートのレイアウトに関してはコードの先頭で Const stRow As Long = 2 '★計画書の最初の社員IDの行番号 Const stCol As Long = 2 '★計画書の最初の社員IDの列番号(B列） Const colRows As Long = 3 '★計画書の1列のセット行数 Const setCols As Long = 2 '★計画書にセットする1データあたりの列数ここを調整すれば、たいていのレイアウトには対応できるようにしてあるつもりだけどここを、実際のレイアウトにあわせて、各数値を変更してもだめだったということ? なら、計画書のレイアウトをもう少し明確にしてもらえないかな? それとも、追加説明は、元ブックの個人用シートのこと? なら、その個人用シートのレイアウトを具体的に明確に教えて欲しい。念のため、現在のコードが処理している個人用シートは・A4:T4がタイトル行、データは5行目から。・E列が所属、Q列が担当者ID、R列が担当者名。O列が要否。A列が社員ID。B列が社員名。 (ぶらっと) ---- さらに念のため。今回も、元ブックの個人用シートの要否欄が ○ のものを抜き出して計画書雛形シートをコピーしたものに転記しているけど、それでいいんだよね? (ぶらっと) ---- ぶらっとさん大変お手数をおかけいたします。説明不足で申し訳ありません。計画書のレイアウトをご説明します。所属のセル番地 AG18 >計画書の最初の社員IDの行番号 22行目です。 >計画書の最初の社員IDの列番号(B列） 33列目です。（補足:最初の社員名の列番号44行目） >計画書の1列のセット行数（社員番号と社員名で4人分）4セットです。 >計画書にセットする1データあたりの列数（社員番号と社員名）2セットです。 >追加説明は、元ブックの個人用シートのこと? いいえ。追加説明は計画書の詳細です。 >念のため、現在のコードが処理している個人用シートは >・A4:T4がタイトル行、データは5行目から。 >・E列が所属、Q列が担当者ID、R列が担当者名。O列が要否。A列が社員ID。B列が社員名。はい。間違いありません。 >今回も、元ブックの個人用シートの要否欄が ○ のものを抜き出して計画書雛形シートをコピーしたも >のに転記しているけど、それでいいんだよね? はい。その通りです。大変お手数をお掛けいたしますがよろしくお願い致します。（はな） ---- 計画書テンプレートのレイアウトが変更になったことは別にして、元ブックの個人用シートのレイアウトがかわっていなければアップしたSample7を実行すれば、なんらかの形（従来、意図していたレイアウト）で計画書AA_666○○さん.xlsx といったブックが作成され、それぞれには該当の社員が全て列挙されるはずなんだけど? もしかしたら原因は、O列の要否。 "○"かどうかの判定をしているんだけど、ここが "○ " といったように、スペースが後ろについていると "○"ではないと見なされ、対象外になる。そのようなことが起こっているって事はない? それより >計画書の最初の社員IDの行番号 22行目です。 >計画書の最初の社員IDの列番号(B列） 33列目です。（補足:最初の社員名の列番号44行目）最初の社員の社員ID と社員名のセット場所は、どこ? 社員IDについては B列という表現と 33列（AG列）という表現があるけど。また、社員名は、従来のコードではC列にしていたけど、それが 44列（AR列)? で、5番目の社員IDと社員名のセット位置は、それぞれどこ? >計画書にセットする1データあたりの列数（社員番号と社員名）2セットです。これは、こちらの表現がわかりにくかったね。社員ID,社員名なのでセットするのは、もちろん 2列なんだけどそうではなく、1〜4の社員をセットした後、列を右にずらして5番目をセットするね。そのずらす列数は、いくつですか? というのが質問の意図だった。 (ぶらっと) ---- ぶらっとさん返信が大変遅くなり申し訳ございません。テンプレートの変更は特にしていないです。要否欄の"○"を確認してもスペースはついていなかったです。 >計画書の最初の社員IDの列番号(B列） 33列目です。（補足:最初の社員名の列番号44行目）こちらはコピペの際に（B列)をはずし忘れてしまったので、最初の社員IDは、22行目/33列目(AG列)です。社員名は、22行目/44列目(AR列)です。 >5番目の社員IDと社員名のセット位置は、それぞれどこ? 5番目は、社員IDは、25行目/66列目社員名は、25行目/76列目です。現状の転記予定の場所は以下になります（セル番地は省略）。わかりにくく申し訳ありません。 @ |C |F | A |D |G | B |E |H | >そのずらす列数は、いくつですか? 大変失礼しました。 23列ずらして頂きたいです。よろしくお願い致します。（はな） ---- う〜ん・・こちらの理解力が乏しいのか・・・まず、1列には社員3つずつはかわらないんだね? >計画書の1列のセット行数（社員番号と社員名で4人分）4セットです。ということなので、4つずつに変更になったのかと思った。であれば最初の社員ID が AG22 なら 2番目は AG23、3番目は AG24 、で、4番目からが 66列（BN列) だとすれば 4番目の社員ID は BN22、5番目は BN23 じゃないの? >5番目は、社員IDは、25行目/66列目だけど、25行目なの? わからないなぁ・・・ (ぶらっと) ---- ごめんなさい。私の説明不足でした。再度確認したところ、4セットでした。何度も申し訳ございません。またわかりにくい表現と思いますが、表が縦3×横8です。以前ご教示頂いた問診票のテンプレートと一緒で編集しやすいようにサイの目のようになっているので、セルの結合をしてセルを加工しています。 33列 44列 66列 76列 98列 108列 131列 141列 22行目 @番目|ID|名前 |C番目|ID|名前 |F番目|ID|名前 | I番目|ID|名前 | ※ 一段目 25行目 A番目|ID|名前 |D番目|ID|名前 |G番目|ID|名前 | J番目|ID|名前 | ※ ニ段目 28行目 B番目|ID|名前 |E番目|ID|名前 |H番目|ID|名前 | K番目|ID|名前 | ※ 三段目よろしくお願い致します。（はな） ---- 新しい計画書レイアウトに対応。しかし・・先に報告のあった、社員が1名しか表示されないということに関しては手当てしていない。なので、もし、そちらの環境で、そうなるバグが内在しているとすれば以下のコードでも同様になるはず。繰り返すけど、こちらでは "〇"のものはすべて反映しているので・・・気になるのは、マクロブック内の作業シートを、こちらのコードではシート名を明記（"Sheet1")しているのにそちらでは、Sheets(1) に変更したこと。Sheets(1) は、ブックの一番左側にあるシート。これを作業シートとして、マクロ内で勝手に使っているわけで、もし、そのシートが重要なシートなら問題だね。さらに、もし、そのシートが、計画書雛形なら、グチャグチャになるはず。 ●作業シートには、ちゃんとした名前をつけて、それを明記しよう。以下のコードでは、前と同じく "Sheet1" にしてある。これを、たとえば"作業シート" といったわかりやすい名前にして、シート名も "作業シート" にかえて運用したほうがいいと思う。（この作業シートは非表示にしておいていいので）あと、考えられるとすれば、社員IDや社員名のセルが縦にセル結合されている。前にアップしたコードが、行方向には1ぎょうずつアップさせて書き込んでいるので、2番目の社員が結合されて隠れているセルに書き込まれて、表からは見えない。（結合セルの裏のセルに書き込むとエラーにはならないけど、書き込みも無視されるので結合解除しても空白だけど）まぁ、いずれにしても試してみて。なお、・マクロブックの計画書シートは、コピーするだけで、そこへの書き込みはしていない。なので、処理後のクリアも行っていない。雛形シートなので、社員ID、社員名が入るセル（24セル）は空白にしておいてね。・該当の社員が24名以上になると、所定のフォーマットには入りきらないので、計画書(2) とか計画書(3) という名前で複数のシートを作成している。 Sub sample8() Dim colsIDs As Variant Dim colsNames As Variant Dim rowsItems As Variant Dim posV As Long Dim posH As Long Dim done As Boolean Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim c As Range Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Dim svPath As String Dim w1 As Long Dim w2 As Long Dim w3 As Long Dim r As Range Dim x As Long Dim id As Variant Dim nm As Variant Dim sz As Variant '計画書シートレイアウトの規定 colsIDs = VBA.Array(33, 66, 98, 131) colsNames = VBA.Array(44, 76, 108, 141) rowsItems = VBA.Array(22, 25, 28) '配列LBoundを1に変更 ReDim Preserve colsIDs(1 To UBound(colsIDs) + 1) ReDim Preserve colsNames(1 To UBound(colsNames) + 1) ReDim Preserve rowsItems(1 To UBound(rowsItems) + 1) 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "担当者別に分解したいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '元ブックの一覧シート Set wSh = ThisWorkbook.Sheets("Sheet1") '★マクロブック内作業シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" '★どのシートのE列なのかを明記した '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:T") '所属、担当者ID,担当者名の組み合わせのユニークなリストを作業シートに生成 wSh.Cells.ClearContents w1 = fList.Columns.Count + 2 w2 = w1 + 4 w3 = w2 + 4 fList.Columns("E").Copy wSh.Cells(1, w1) '所属 fList.Columns("Q").Copy wSh.Cells(1, w1 + 1) '担当者ID fList.Columns("R").Copy wSh.Cells(1, w1 + 2) '担当者名 wSh.Cells(1, w1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=wSh.Cells(1, w2), Unique:=True wSh.Cells(1, w3).Resize(, 3).Value = wSh.Cells(1, w1).Resize(, 3).Value wSh.Cells(1, w3 + 3).Value = fSh.Range("O4").Value '要否タイトル 'ユニークなリストから条件を取り出しフィルターオプション実行 With wSh.Cells(1, w2).CurrentRegion.Columns(1) For Each r In .Resize(.Rows.Count - 1).Offset(1).Cells wSh.Cells(2, w3).Resize(, 3).Value = r.Resize(, 3).Value wSh.Cells(2, w3 + 3).Value = "○" wSh.Columns("A").Resize(, fList.Columns.Count).ClearContents fList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wSh.Cells(1, w3).CurrentRegion, _ CopyToRange:=wSh.Range("A1"), Unique:=False x = wSh.Range("A1").CurrentRegion.Rows.Count 'タイトル行含めた抽出行数 If x > 1 Then '抽出があれば sz = wSh.Cells(2, w3).Value '所属 id = wSh.Cells(2, w3 + 1).Value '担当者ID nm = wSh.Cells(2, w3 + 2).Value '担当者名 posV = 0 posH = 1 done = False '抽出したリストから対象データを配列に格納 For Each c In wSh.Range("A2", wSh.Range("A" & wSh.Rows.Count).End(xlUp)) posV = posV + 1 If posV > UBound(rowsItems) Then posV = 1 posH = posH + 1 If posH > UBound(colsIDs) Then posH = 1 End If If posV = 1 And posH = 1 Then If Not done Then ThisWorkbook.Sheets("計画書").Copy 'マクロ内テンプレートから新規ブックを生成 Set tSh = ActiveSheet done = True Else ThisWorkbook.Sheets("計画書").Copy After:=tSh Set tSh = tSh.Next End If tSh.Range("AG18").Value = sz End If tSh.Cells(rowsItems(posV), colsIDs(posH)).Value = c.Value '社員ID tSh.Cells(rowsItems(posV), colsNames(posH)).Value = c.Offset(, 1).Value '社員名 Next fName = "計画書" & sz & "_" & id & nm & "さん" & ".xlsx" Application.DisplayAlerts = False '同名ブックがあれば無条件上書き tSh.Parent.SaveAs svPath & fName Application.DisplayAlerts = True tSh.Parent.Close False '作成したブックを閉じる End If Next End With wSh.Cells.Clear wb.Close False '元ブックを閉じる Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub (ぶらっと) ---- ぶらっとさんご指示頂きましたとおり、作業用シーという名前のシート作り、 Set wSh = ThisWorkbook.Sheets("Sheet1") から Set wSh = ThisWorkbook.Sheets("作業用シート") に変更してからマクロを実行したところ、問題なく処理できました。大変助かりました。有難うございました。大変申し訳ございません。あと一つご教示頂けませんでしょうか。何卒宜しくお願い致します。基本的な処理となります。元ブックの個人用シートの要否欄が ○ のものを抜き出して残業報告雛形シートをコピーしたものに転記する処理したいと考えています。今までご教示頂いたマクロは、○ のものを抜き出して1行ごとにつき新規ファイル作成の処理となっていましたが、今回は、○ ものを抜き出して残業報告雛形シートをにコピーしたものに全て転記する処理を考えています。【元データ】（前回ご教示頂いたファイル・シートともに同じです。） シート名【個人用】タイトル等A1〜R4 A B ・・ E ・ G ・・・ K L M N O P Q R 社員番号社員名所属名事業所名時間外合計（h）前月時間外合計前々月時間外合計 3ヶ月分の平均問診票削減書（個人）担当者ID 担当者 5 0000 あああ AA 1 100 80 90 90.0 ○ ○ 6666 ○○ 6 1111 いいい AA 1 62 48 50 53.3 6666 ○○ 7 2222 ううう BB 2 85 95 80 86.7 ○ ○ 7777 ■■ 8 3333 えええ CC 3 120 87 50 85.7 ○ ○ 8888 △△ 9 4444 おおお CC 3 62 48 50 53.3 8888 △△ 【マクロ処理後】ファイル名問診票チェックリスト2013.05.xls A B E G K L M N O P Q R 社員番号社員名所属名事業所名時間外合計（h）前月時間外合計前々月時間外合計 3ヶ月分の平均問診票削減書（個人）担当者ID 担当者 0000 あああ AA 1 100 80 90 90.0 ○ ○ 6666 ○○ 2222 ううう BB 2 85 95 80 86.7 ○ ○ 7777 ■■ 3333 えええ CC 3 120 87 50 85.7 ○ ○ 8888 △△ 【補足】 O列とP列についている ○ がついている箇所は両方ついています。参考にはなりませんが途中までコードを作成しましたので念ため貼り付けます。 ※このサンプルは、○ がついている行を検索し、新規ファイルを作成の繰り返し処理になっています。 Sub サンプル作成() Dim fSh As Worksheet Dim wSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim i As Long Dim svPath As String Dim fName As String Dim ff As Variant Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 yyyymm = Application.InputBox("元データの「月」を入力してください" & vbLf & "例:（前月）2013年5月 → 2013.05", Type:=1) 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls", , "前月のファイルを指定してください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) Set fSh = wb.Sheets("個人用") Set tSh = ThisWorkbook.Sheets("残業報告") '★マクロブック内作業シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" For Each c In fSh.Range("A5", fSh.Range("A" & fSh.Rows.Count).End(xlUp)) With c.EntireRow If .Range("O1").Value = "○" Then '残業報告対象 tSh.Range("A1").Value = yyyymm '月 tSh.Range("A5").Value = .Range("A1").Value '社員番号 tSh.Range("B5").Value = .Range("B1").Value '社員名 tSh.Range("C5").Value = .Range("E1").Value '所属名 tSh.Range("D5").Value = .Range("G1").Value '事業所 tSh.Range("E5").Value = .Range("K1").Value '時間外合計（h） tSh.Range("F5").Value = .Range("L1").Value '前月時間外合計 tSh.Range("G5").Value = .Range("M1").Value '前々月時間外合計 tSh.Range("H5").Value = .Range("N1").Value '3ヶ月分の平均 tSh.Range("I5").Value = .Range("O1").Value '問診票 tSh.Range("J5").Value = .Range("P1").Value '削減書（個人） tSh.Range("K5").Value = .Range("Q1").Value '担当者ID tSh.Range("L5").Value = .Range("R1").Value '担当者 fName = "問診票チェックリスト" & yyyymm & ".xls" tSh.Copy '新規ブック Application.DisplayAlerts = False '同名ブックがあれば無条件上書き With ActiveWorkbook .SaveAs svPath & fName .Close End With End If End With Next Application.ScreenUpdating = True MsgBox "分解・保存完了" End Sub この期に及んで何度もご教示頂いて申し訳ございません。何卒宜しくお願い致します。（はな） ---- 今回のテーマは、これまでのものよりシンプル。フィルターオプション一発で作表できる。コードを見てもらえばわかるけど、このための処理は、ほんの2〜3行で書くことができる。コードの前に、今までも気になっていて、でも処理上、必要がなかったのでコメントしなかったけど元ブックの個人用シートに『何月のデータなのか』その情報がなかったね。（あったのかもしれないけど）今回は、保存する新規ブックの年月情報が必要なので、どこかに『日付型(yyyy/mm/dd)』の欄を作ってほしい。（もし、すでにあれば、そこでいい）コードでは、個人用シートの A1 にしてある。日付型なので日まであるわけだけど、表示形式で年月だけにしておけば体裁もいいかも。この場所は実際のものに変更してね。（コードで ★ をつけてあるところ）また、元ブックの個人用シート、そのものをコピーして使うので、マクロブックに、これようの雛形シートは不要。 Sub Sample9() Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 Dim fSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Dim svPath As String 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "元ブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '元ブックの一覧シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" fSh.Copy '個人用シートをいったん全てコピーして新規ブックを作る Set tSh = ActiveSheet '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '今回の処理フィルターオプション一発で。 tSh.Range("T1").Value = fSh.Range("O4").Value '問診票要否欄タイトル tSh.Range("T2").Value = "○" '抽出条件 fList.AdvancedFilter Action:= _ xlFilterCopy, CriteriaRange:=tSh.Range("T1:T2"), CopyToRange:=tSh.Range("A4:R4"), Unique:=False tSh.Range("T1:T2").Clear 'もし、チェックリストタイトルを1行目からにいたい場合は、上記にかえて以下 'tSh.Rows("1:3").Delete fName = "問診票チェックリスト" & Format(fSh.Range("A1").Value, "yyyy.mm") & ".xls" '★ Application.DisplayAlerts = False '同名ブックがあれば無条件上書き tSh.Parent.SaveAs svPath & fName Application.DisplayAlerts = True tSh.Parent.Close False '作成したブックを閉じる wb.Close False '元ブックを閉じる Application.ScreenUpdating = True MsgBox "チェックリストを作成して保存しました" End Sub (ぶらっと) ---- ぶらっとさん早速ご教示頂きまして有難うございます。問題なく処理ができました。日付型(yyyy/mm/dd)は、暫定でセット頂いたところにありましたので、ファイル名の名前に含めることができました。大変申し訳ございません!! お伝えする内容が実際と異なっておりました。元ブックの個人用シートの要否欄が ○ のものを抜き出して、さらにA列からR列全体コピーではなく、部分的にコピーをして転記するという処理でした。何度もお手間をとらせてしまい申し訳ございません。【元ファイル】タイトル等A1〜R4 A〜R列 ※ 要否欄が ○ のものを抜き出してマクロ実行後 ↓ 【転記先】タイトル等A1〜R4 A,B,E,G,K,L,M,N,O,P,Q,R列 ※S列・T列に今回の処理に含まない（転記したくない）データがあります。大変お手数をお掛け致しますが何卒よろしくお願い致します。（はな） ---- それでは以下。元ブックからのシートコピーをやめ、本当の新規ブックから作成しているので、できあがりのシートの列幅や表示書式がお気に召さないかもしれない。どうしても具合悪ければ、マクロクックに雛形シートを作ってそれをベースにすることはできる。なお、今回は、1行目がタイトル行のチェックリストにしている。 Sub Sample10() Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 Dim fSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Dim svPath As String Dim svShCnt As Long 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "元ブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '元ブックの一覧シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" svShCnt = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Workbooks.Add Application.SheetsInNewWorkbook = svShCnt Set tSh = ActiveSheet '抽出項目限定 tSh.Range("A1:L1").Value = _ Array(fSh.Range("A4").Value, fSh.Range("B4").Value, fSh.Range("E4").Value, fSh.Range("G4").Value, _ fSh.Range("L4").Value, fSh.Range("L4").Value, fSh.Range("M4").Value, fSh.Range("N4").Value, _ fSh.Range("O4").Value, fSh.Range("P4").Value, fSh.Range("Q4").Value, fSh.Range("R4").Value) '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '今回の処理フィルターオプション一発で。 tSh.Range("T1").Value = fSh.Range("O4").Value '問診票要否欄タイトル tSh.Range("T2").Value = "○" '抽出条件 fList.AdvancedFilter Action:= _ xlFilterCopy, CriteriaRange:=tSh.Range("T1:T2"), CopyToRange:=tSh.Range("A1:L1"), Unique:=False tSh.Range("T1:T2").Clear fName = "問診票チェックリスト" & Format(fSh.Range("A1").Value, "yyyy.mm") & ".xls" '★ Application.DisplayAlerts = False '同名ブックがあれば無条件上書き tSh.Parent.SaveAs svPath & fName Application.DisplayAlerts = True tSh.Parent.Close False '作成したブックを閉じる wb.Close False '元ブックを閉じる Application.ScreenUpdating = True MsgBox "チェックリストを作成して保存しました" End Sub (ぶらっと) ---- ぶらっとさん有難うございます。問題なく処理ができました。提出用に作成しておりますので、やはり雛形に転記する形にして頂くと大変有難いです。 "残業報告"というテンプレートのシートを作成しました。タイトル内容は以下です。 A B C D E F G H I J K L 社員番号社員名所属名事業所名時間外合計（h）前月時間外合計前々月時間外合計 3ヶ月分の平均問診票削減書（個人）担当者ID 担当者なお、"残業報告"シートのA1に日付形式を入れておりますので元データから転記できれば有難いです。何度もお手間を取らせてしまいまして申し訳ございません。（はな） ---- テンプレートのタイトル行も4行目（A4:L4) と想定。もし、違っていれば、★印のコードの A4:L4 を変更。 Sub Sample11() Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可 Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示 Dim fSh As Worksheet Dim tSh As Worksheet Dim fList As Range Dim ff As Variant Dim fName As String Dim wb As Workbook Dim fd As Object Dim Shell As Object, myPath As Object Dim hWnd As Long Dim svPath As String 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "元ブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン '保存フォルダの選択 hWnd = Application.hWnd Set Shell = CreateObject("Shell.Application") Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _ BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX) If fd Is Nothing Then Exit Sub 'キャンセルボタン svPath = fd.Items.Item.Path & "¥" Application.ScreenUpdating = False Set wb = Workbooks.Open(ff) '元ブックを開く Set fSh = wb.Sheets("個人用") '元ブックの一覧シート '禁則記号置換 fSh.Columns("E:E").Replace What:="/", Replacement:="_" ThisWorkbook.Sheets("残業報告").Copy '新規ブック作成 Set tSh = ActiveSheet tSh.Range("A1").Value = fSh.Range("A1").Value '報告月 '元ブックのリスト領域 Set fList = fSh.Range("A4", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Columns("A:R") '今回の処理フィルターオプション一発で。 tSh.Range("T1").Value = fSh.Range("O4").Value '問診票要否欄タイトル tSh.Range("T2").Value = "○" '抽出条件 fList.AdvancedFilter Action:= _ xlFilterCopy, CriteriaRange:=tSh.Range("T1:T2"), CopyToRange:=tSh.Range("A4:L4"), Unique:=False '★ tSh.Range("T1:T2").Clear fName = "問診票チェックリスト" & Format(fSh.Range("A1").Value, "yyyy.mm") & ".xls" Application.DisplayAlerts = False '同名ブックがあれば無条件上書き tSh.Parent.SaveAs svPath & fName Application.DisplayAlerts = True tSh.Parent.Close False '作成したブックを閉じる wb.Close False '元ブックを閉じる Application.ScreenUpdating = True MsgBox "チェックリストを作成して保存しました" End Sub (ぶらっと) ---- ぶらっとさん問題なく処理ができました。多岐にわたって懇切丁寧にご教示頂きまして有難うございました。大変助かりました。ご教示頂いたことを勉強させて頂きます。困ったことがありましたらまた投稿させて頂きます。次の投稿の際には今よりレベルアップするように努力致します。有難うございました。（はな） ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/201305/20130512101712.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ