[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データリストから担当ごとに振分』（はな）
はじめまして。
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
いろんな方法があるけどエクセル操作をベースにすれば
１．元ブックの、このシートのＱ４～Ｒ●に対してフィルターオプションで重複を無視してＴ列あたりに抽出。 これで、ユニークな担当者リストができあがる ２．このユニークな担当者リストのそれぞれに対して １）新規ブックを生成(元ブックのシートから作成） ２）元ブックのＡ４～Ｑ●のリストから、ユニークな担当者リストのそれぞれの値を抽出キーにして 新規ブックのシートの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("Ｅｘｃｅｌブック,*.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") & "\担当者別\"に修正したところ、問題なくファイル作成をすることができました。
大変助かりました。
有難うございました。
（はな）
とりあえず、うまくいったようでよかった。
>同じデータで、新しくファイルを作らず、 >担当別ごとにシートに名前をつけて振り分ける方法を教えて頂けないでしょうか。
元ブックにシートとして追加したい？ それとも、担当者別シートにわけた形の１つの新規ブックにしたい？
運用面も考えると後者のほうがいいと思うけど。
(ぶらっと)
おかげさまで上手くいきました。
有難うございました。
お問い合わせの件ですが、
担当別シートにわけた形の１つの新規ブックにしたいと考えています。
大変お手数をおかけいたしますがよろしくお願い致します。
（はな）
元ブックも、新規ブックも同じフォルダのようなので、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か月前時間外 ２カ月前時間外 問診票対象者 担当者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")
ｅ－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") = 月 こちらは、【問診用】です。
（はな）
了解。コードを書いてみるけど、それとは別に。
>セルの結合をすると上手くマクロが処理されないので、転記後セルを結合しています。。
結合セルはやっかいだけど、かといって転記できないわけでもない。 うまくいかないコードをサンプルとしてアップしてもらえないかな？
追記で。
問診票側のセル結合だけど、おそろしく、横にたくさんの数のセルが結合されているね。 たとえば、社員番号に対して、５０セル！！ 間違いないんだよね？
もう１つ。
これまでのものは担当者別に抽出しているけど、今回は、社員別だね。 で、これまでのものは、元シートに同じ担当者データが複数あったけど、社員データは 元シートにユニークに１行だけと考えていいのかな？
(ぶらっと)
とりあえず書いてみた。仕様の勘違いあれば指摘乞う。 なお、上でもコメントしたけど、こちらでは問診票テンプレートシートのセルを結合させていて そこに直接転記している。なので、新規ブックがわでは何もしていない。
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 '社員ＩＤ
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 '１か月前時間外
tSh.Range("EF34").Value = .Range("M1").Value '２か月前時間外
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セルあります。
転記データの下に問診票のチェックリスト作成しています。
そのためセルを細かくしなければならなかったため、サイの目状にシートを加工しています。
>これまでのものは担当者別に抽出しているけど、今回は、社員別だね。
はい。前回までは担当者別での抽出でしたが、
今回はO列の問診票対象者の「○」のフラグがある人を抽出し、
順にテンプレートに転記するというものです。
で、これまでのものは、元シートに同じ担当者データが複数あったけど、社員データは 元シートにユニークに１行だけと考えていいのかな？
はい。社員データは、複数いないので、１行だけです。
私の作ったサンプルは記録マクロのようなコードですので、
大変見づらいと思いますがよろしくお願い致します。
（概要）個人用シートから問診票対象者の「○」のフラグがある人を抽出し、
新規シートにデータを転記し、さらにテンプレートにデータを転記しています。
見なおしてみるとすごい方法でコードを作っていますね。。
本当に見づらくて申し訳ありません。
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
'ｅ－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
'②個人用Sheetのｵｰﾄﾌｨﾙﾀ解除
Sheets("個人用").Select
Selection.AutoFilter
Range("A4").Select
'③問診票のデータ削除
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を勉強していく上で参考にさせて頂きます。
ご指示頂きましたとおり、
セルを結合してからマクロを実行したところ無事にファイルを作成することが出来ました。
有難うございました。
作成頂きましたコードで２点ご教示頂けますでしょうか。
何度も申し訳ございません。
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 は、それらが【規定値】の設定になる。これは許可したいというものが規定値以外にあれば それらを引数で指定必要。
ついでに。
シート保護は、手っ取り早く、元のテンプレートシートには保護がかかっておらず、新規に作ったものに保護をかける 方式にしたけど、以下のようなこともできる。ご参考まで。
１）もし、コードでセットしているセルが、新規ブック側でも、入力可能セルなら、元ブックのテンプレート側に シート保護をかけておいて、マクロでは、シート保護に関しては何もしない。 （ただ、今回の要件では、コードでセットしているセルは新規ブックでは、入力不可だと思うので、この方式はＮＧだね） ２）元ブックのテンプレート側をシート保護しておき、 ・新規ブックとして生成した後、マクロ内で非保護にして、セルに値をセットして、その後マクロ内でシート保護に戻す。 ・あるいは、マクロ内でセルに値をセットする前に、操作者は操作できないけどマクロでの書き込み等はできるような 「おまじない」をコードに書く。
(ぶらっと)
無事に動作しました。
シート保護に関しましては入力箇所のみロックを外した状態でマクロで保護をかけたところ、
うまくいきました。
有難うございました！！
今日、会社でマクロを動かしデスクトップで作業すると申し上げたのですが、
やはり、今後のことを考えるとファイルを選択をしてからネットワーク上のフォルダに保存する方法が良さそうです。。。
自分で加工しようと思いましたが、
マクロを動かすとマクロのみのエクセルファイルに担当者のデータがコピーされてしまい、
保存がうまくできませんでした。
ご教示頂けると大変助かります。
御願いばかりで申し訳ございません。
（はな）
>やはり、今後のことを考えるとファイルを選択をしてからネットワーク上のフォルダに保存する方法が良さそうです。。。
・ファイルを選択してから・・・というのが、最初に元ブックを操作者がダイアログから指定して開くということであれば 一番最初にアップしたコードのあるように、 Dim ff As Variant といったものを追加しておき プロシジャの最初に
'ブックの選択
ff = Application.GetOpenFilename("Ｅｘｃｅｌブック,*.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("Ｅｘｃｅｌブック,*.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 '社員ＩＤ
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 '１か月前時間外
tSh.Range("EF34").Value = .Range("M1").Value '２か月前時間外
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 = "" '社員ＩＤ
tSh.Range("DG18").Value = "" '社員名
tSh.Range("DG21").Value = "" '年齢
tSh.Range("DG24").Value = "" '性別
tSh.Range("BG34").Value = "" '時間外合計
tSh.Range("CU34").Value = "" '１か月前時間外
tSh.Range("EF34").Value = "" '２か月前時間外
Application.ScreenUpdating = True
MsgBox "分解・保存 完了"
End Sub
(ぶらっと)
返信が大変遅くなり申し訳ございません。
ご教示頂きましたコードを実行したところ問題なく処理が出来ました。
有難うございました。
大変助かりました。
以前にもう１つだけと申し上げましたが、大変申し訳ございません。
全部で３つ（２つはご教示頂きました）のマクロコードを作成しており、
最後の１つがコード作成が大変難しく手を焼いております。
もし宜しければご教示頂けないでしょうか。
何卒宜しくお願い致します。
【概要】元データの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 あああ ‘④ ‘⑦
‘②1111 いいい ‘⑤ ‘⑧
‘③ ‘⑥ ‘⑨
色々要望を申し上げて申し訳ございません。
丸枠番号順に社員IDと社員名を転記できることが理想的です。
完成には程遠いですが、ご教示頂いた箇所を引用しコードを作成致しましたがこれ以上は力不足で先に進めなくなっております。
最終的には３つのマクロを通しで実行できるように考えております。
ご教示頂けると大変助かります。
何卒宜しくお願い致します。
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("Ｅｘｃｅｌブック,*.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 '社員番号②
tSh.Range("AR25").Value = .Range("B2").Value '社員名②
tSh.Range("AG28").Value = .Range("A3").Value '社員番号③
tSh.Range("AR28").Value = .Range("B3").Value '社員名③
tSh.Range("BN22").Value = .Range("A4").Value '社員番号④
tSh.Range("BX22").Value = .Range("B4").Value '社員名④
tSh.Range("BN25").Value = .Range("A5").Value '社員番号⑤
tSh.Range("BX25").Value = .Range("B5").Value '社員名⑤
tSh.Range("BN28").Value = .Range("A6").Value '社員番号⑥
tSh.Range("BX28").Value = .Range("B6").Value '社員名⑥
tSh.Range("CR22").Value = .Range("A7").Value '社員番号⑦
tSh.Range("DD22").Value = .Range("B7").Value '社員名⑦
tSh.Range("CR25").Value = .Range("A8").Value '社員番号⑧
tSh.Range("DD25").Value = .Range("B8").Value '社員名⑧
tSh.Range("CR22").Value = .Range("A9").Value '社員番号⑨
tSh.Range("DD28").Value = .Range("B9").Value '社員名⑨
tSh.Range("DX22").Value = .Range("A10").Value '社員番号⑩
tSh.Range("EJ22").Value = .Range("B10").Value '社員名⑩
tSh.Range("DX25").Value = .Range("A11").Value '社員番号⑪
tSh.Range("EJ25").Value = .Range("B11").Value '社員名⑪
tSh.Range("DX28").Value = .Range("A12").Value '社員番号⑫
tSh.Range("EJ28").Value = .Range("B12").Value '社員名⑫
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 = "" '社員番号②
tSh.Range("AR25").Value = "" '社員名②
tSh.Range("AG28").Value = "" '社員番号③
tSh.Range("AR28").Value = "" '社員名③
tSh.Range("BN22").Value = "" '社員番号④
tSh.Range("BX22").Value = "" '社員名④
'tSh.Range("BN25").Value = "" '社員番号⑤
'tSh.Range("BX25").Value = "" '社員名⑤
'tSh.Range("BN28").Value = "" '社員番号⑥
'tSh.Range("BX28").Value = "" '社員名⑥
'tSh.Range("CR22").Value = "" '社員番号⑦
'tSh.Range("DD22").Value = "" '社員名⑦
'tSh.Range("CR25").Value = "" '社員番号⑧
'tSh.Range("DD25").Value = "" '社員名⑧
'tSh.Range("CR22").Value = "" '社員番号⑨
'tSh.Range("DD28").Value = "" '社員名⑨
'tSh.Range("DX22").Value = "" '社員番号⑩
'tSh.Range("EJ22").Value = "" '社員名⑩
'tSh.Range("DX25").Value = "" '社員番号⑪
'tSh.Range("EJ25").Value = "" '社員名⑪
'tSh.Range("DX28").Value = "" '社員番号⑫
'tSh.Range("EJ28").Value = "" '社員名⑫
Application.ScreenUpdating = True
MsgBox "分解・保存 完了"
（はな）
コードを読めば要件がわかるのかもしれないけど、説明文だけを読んだレベルでの質問。
できあがるブック名が 計画書0000あああさん.xls だとすると、Ａ列、Ｂ列でまとめる（社員番号と名前）のように思えるけど できあがりイメージの例では、中味として 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 '★計画書の１列のセット行数
Const setCols As Long = 2 '★計画書にセットする１データあたりの列数
これらで、規定している。実態と異なれば、ここを変更。 なお、所属別にブックをわけるということなので、ブック名は 計画書AA_6666〇〇さん.xlsx にしてある。
Sub sample7()
Const stRow As Long = 2 '★計画書の最初の社員IDの行番号
Const stCol As Long = 2 '★計画書の最初の社員IDの列番号(B列）
Const colRows As Long = 3 '★計画書の１列のセット行数
Const setCols As Long = 2 '★計画書にセットする１データあたりの列数
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("Ｅｘｃｅｌブック,*.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")
'所属、担当者ＩＤ，担当者名の組み合わせのユニークなリストを作業シートに生成
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列目|④（22行目/66列目|22行目/76列目|・・
｜②25行目/33列目|25行目/44列目|⑤（25行目/66列目|25行目/76列目|・・
｜③28行目/33列目|28行目/44列目|⑥（28行目/66列目|28行目/76列目|・・
今、転記されているのは①の社員番号のみです。
（はな）
計画書シートのレイアウトに関してはコードの先頭で
Const stRow As Long = 2 '★計画書の最初の社員IDの行番号
Const stCol As Long = 2 '★計画書の最初の社員IDの列番号(B列）
Const colRows As Long = 3 '★計画書の１列のセット行数
Const setCols As Long = 2 '★計画書にセットする１データあたりの列数
ここを調整すれば、たいていのレイアウトには対応できるようにしてあるつもりだけど ここを、実際のレイアウトにあわせて、各数値を変更してもだめだったということ？
なら、計画書のレイアウトをもう少し明確にしてもらえないかな？
それとも、追加説明は、元ブックの個人用シートのこと？ なら、その個人用シートのレイアウトを具体的に明確に教えて欲しい。
念のため、現在のコードが処理している個人用シートは ・A4:T4がタイトル行、データは5行目から。 ・E列が所属、Q列が担当者ID、R列が担当者名。O列が要否。A列が社員ID。B列が社員名。
(ぶらっと)
さらに念のため。
今回も、元ブックの個人用シートの要否欄が ○ のものを抜き出して 計画書雛形シートをコピーしたものに 転記しているけど、それでいいんだよね？
(ぶらっと)
大変お手数をおかけいたします。
説明不足で申し訳ありません。
計画書のレイアウトをご説明します。
所属のセル番地 AG18
計画書の最初の社員IDの行番号 22行目です。
計画書の最初の社員IDの列番号(B列） 33列目です。（補足：最初の社員名の列番号44行目）
計画書の１列のセット行数 （社員番号と社員名で4人分）4セットです。
計画書にセットする１データあたりの列数 （社員番号と社員名）2セットです。
追加説明は、元ブックの個人用シートのこと？ いいえ。追加説明は計画書の詳細です。
念のため、現在のコードが処理している個人用シートは ・A4:T4がタイトル行、データは5行目から。 ・E列が所属、Q列が担当者ID、R列が担当者名。O列が要否。A列が社員ID。B列が社員名。 はい。間違いありません。
今回も、元ブックの個人用シートの要否欄が ○ のものを抜き出して 計画書雛形シートをコピーしたも >のに 転記しているけど、それでいいんだよね？ はい。その通りです。
大変お手数をお掛けいたしますがよろしくお願い致します。
（はな）
計画書テンプレートのレイアウトが変更になったことは別にして、元ブックの個人用シートのレイアウトがかわっていなければ アップしたSample7を実行すれば、なんらかの形（従来、意図していたレイアウト）で 計画書AA_666○○さん.xlsx といったブックが 作成され、それぞれには該当の社員が全て列挙されるはずなんだけど？
もしかしたら原因は、Ｏ列の要否。 "○"かどうかの判定をしているんだけど、ここが "○ " といったように、スペースが後ろについていると "○"ではないと見なされ、対象外になる。そのようなことが起こっているって事はない？
それより
>計画書の最初の社員IDの行番号 22行目です。 >計画書の最初の社員IDの列番号(B列） 33列目です。（補足：最初の社員名の列番号44行目）
最初の社員の社員ID と 社員名のセット場所は、どこ？ 社員IDについては B列 という表現と 33列（AG列） という表現があるけど。 また、社員名は、従来のコードではC列にしていたけど、それが 44列（AR列)？
で、５番目の社員IDと社員名のセット位置は、それぞれどこ？
>計画書にセットする１データあたりの列数（社員番号と社員名）2セットです。
これは、こちらの表現がわかりにくかったね。社員ID,社員名 なので セットするのは、もちろん 2列なんだけど そうではなく、１～４の社員をセットした後、列を右にずらして５番目をセットするね。 そのずらす列数は、いくつですか？ というのが質問の意図だった。
(ぶらっと)
返信が大変遅くなり申し訳ございません。
テンプレートの変更は特にしていないです。
要否欄の"○"を確認してもスペースはついていなかったです。
計画書の最初の社員IDの列番号(B列） 33列目です。（補足：最初の社員名の列番号44行目） こちらはコピペの際に（B列)をはずし忘れてしまったので、
最初の社員IDは、22行目/33列目(AG列)です。
社員名は、22行目/44列目(AR列)です。
５番目の社員IDと社員名のセット位置は、それぞれどこ？
5番目は、社員IDは、25行目/66列目 社員名は、25行目/76列目です。
現状の転記予定の場所は以下になります（セル番地は省略）。
わかりにくく申し訳ありません。
① ｜④ ｜⑦ ｜
② ｜⑤ ｜⑧ ｜
③ ｜⑥ ｜⑨ ｜
そのずらす列数は、いくつですか？
大変失礼しました。
23列ずらして頂きたいです。
よろしくお願い致します。
（はな）
う～ん・・こちらの理解力が乏しいのか・・・
まず、１列には社員３つずつはかわらないんだね？
>計画書の１列のセット行数（社員番号と社員名で4人分）4セットです。
ということなので、４つずつに変更になったのかと思った。
であれば 最初の社員ID が AG22 なら ２番目は AG23、３番目は AG24 、で、４番目からが 66列（BN列) だとすれば ４番目の社員ID は BN22、５番目は BN23 じゃないの？
>5番目は、社員IDは、25行目/66列目
だけど、25行目なの？
わからないなぁ・・・
(ぶらっと)
またわかりにくい表現と思いますが、表が縦３×横８です。
以前ご教示頂いた問診票のテンプレートと一緒で編集しやすいようにサイの目のようになっているので、セルの結合をしてセルを加工しています。
33列 44列 66列 76列 98列 108列 131列 141列
22行目 ①番目｜ID｜名前 ｜④番目｜ID｜名前 ｜⑦番目｜ID｜名前 ｜ ⑩番目｜ID｜名前 | ※ 一段目
25行目 ②番目｜ID｜名前 ｜⑤番目｜ID｜名前 ｜⑧番目｜ID｜名前 ｜ ⑪番目｜ID｜名前 | ※ ニ段目
28行目 ③番目｜ID｜名前 ｜⑥番目｜ID｜名前 ｜⑨番目｜ID｜名前 ｜ ⑫番目｜ID｜名前 | ※ 三段目
よろしくお願い致します。
（はな）
新しい計画書レイアウトに対応。 しかし・・先に報告のあった、社員が１名しか表示されないということに関しては手当てしていない。 なので、もし、そちらの環境で、そうなるバグが内在しているとすれば以下のコードでも同様になるはず。
繰り返すけど、こちらでは "〇"のものはすべて反映しているので・・・ 気になるのは、マクロブック内の作業シートを、こちらのコードではシート名を明記（"Sheet1")しているのに そちらでは、Sheets(1) に変更したこと。Sheets(1) は、ブックの一番左側にあるシート。 これを作業シートとして、マクロ内で勝手に使っているわけで、もし、そのシートが重要なシートなら問題だね。 さらに、もし、そのシートが、計画書雛形なら、グチャグチャになるはず。
●作業シートには、ちゃんとした名前をつけて、それを明記しよう。以下のコードでは、前と同じく "Sheet1" にしてある。 これを、たとえば"作業シート" といったわかりやすい名前にして、シート名も "作業シート" にかえて運用したほうが いいと思う。（この作業シートは非表示にしておいていいので）
あと、考えられるとすれば、社員IDや社員名のセルが縦にセル結合されている。前にアップしたコードが、行方向には１ぎょうずつ アップさせて書き込んでいるので、２番目の社員が結合されて隠れているセルに書き込まれて、表からは見えない。 （結合セルの裏のセルに書き込むとエラーにはならないけど、書き込みも無視されるので結合解除しても空白だけど）
まぁ、いずれにしても試してみて。 なお、
・マクロブックの計画書シートは、コピーするだけで、そこへの書き込みはしていない。 なので、処理後のクリアも行っていない。 雛形シートなので、社員ID、社員名 が入るセル（２４セル）は空白にしておいてね。 ・該当の社員が２４名以上になると、所定のフォーマットには入りきらないので、計画書(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("Ｅｘｃｅｌブック,*.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")
'所属、担当者ＩＤ，担当者名の組み合わせのユニークなリストを作業シートに生成
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("作業用シート") に変更してからマクロを実行したところ、
問題なく処理できました。
大変助かりました。
有難うございました。
大変申し訳ございません。
あと一つご教示頂けませんでしょうか。
何卒宜しくお願い致します。
基本的な処理となります。
元ブックの個人用シートの要否欄が ○ のものを抜き出して残業報告雛形シートをコピーしたものに転記する処理したいと考えています。
今までご教示頂いたマクロは、○ のものを抜き出して１行ごとにつき新規ファイル作成の処理となっていましたが、
今回は、○ ものを抜き出して残業報告雛形シートをにコピーしたものに全て転記する処理を考えています。
【元データ】 （前回ご教示頂いたファイル・シートともに同じです。）
シート名 【個人用】
タイトル等A1～R4
A Ｂ ･･ E ･ G ･･･ K L M N O P Q R
社員番号 社員名 所属名 事業所名 時間外合計（ｈ） 前月時間外合計 前々月時間外合計 3ヶ月分の平均 問診票 削減書（個人） 担当者ＩＤ 担当者
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 Ｂ E G K L M N O P Q R
社員番号 社員名 所属名 事業所名 時間外合計（ｈ） 前月時間外合計 前々月時間外合計 3ヶ月分の平均 問診票 削減書（個人） 担当者ＩＤ 担当者
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("Ｅｘｃｅｌブック,*.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 '時間外合計（ｈ）
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
この期に及んで何度もご教示頂いて申し訳ございません。
何卒宜しくお願い致します。
（はな）
今回のテーマは、これまでのものよりシンプル。フィルターオプション一発で作表できる。 コードを見てもらえばわかるけど、このための処理は、ほんの２～３行で書くことができる。
コードの前に、今までも気になっていて、でも処理上、必要がなかったのでコメントしなかったけど 元ブックの個人用シートに『何月のデータなのか』その情報がなかったね。（あったのかもしれないけど） 今回は、保存する新規ブックの年月情報が必要なので、どこかに『日付型(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("Ｅｘｃｅｌブック,*.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("Ｅｘｃｅｌブック,*.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
社員番号 社員名 所属名 事業所名 時間外合計（ｈ） 前月時間外合計 前々月時間外合計 3ヶ月分の平均 問診票 削減書（個人） 担当者ＩＤ 担当者
なお、"残業報告"シートのA1に日付形式を入れておりますので元データから転記できれば有難いです。
何度もお手間を取らせてしまいまして申し訳ございません。
（はな）
テンプレートのタイトル行も４行目（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("Ｅｘｃｅｌブック,*.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
(ぶらっと)
問題なく処理ができました。
多岐にわたって懇切丁寧にご教示頂きまして有難うございました。
大変助かりました。
ご教示頂いたことを勉強させて頂きます。
困ったことがありましたらまた投稿させて頂きます。
次の投稿の際には今よりレベルアップするように努力致します。
有難うございました。
（はな）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.