Results of 1 - 1 of about 37699 for IF (0.008 sec.)
- [[20130613140402]]
- #score: 1591
- @digest: 21e115106545fa8cbce8338b8ada6168
- @id: 62648
- @mdate: 2013-10-10T09:44:31Z
- @size: 51476
- @type: text/plain
- #keywords: diccell (147616), bkold (130826), 施設 (126565), 設シ (117182), dicsh (85126), bknew (77465), 設a (73452), 昔作 (54741), 設の (35644), fname (34224), mypath (25115), （^ (17922), 目次 (17102), 在作 (16482), ブッ (12153), 成中 (8766), workbooks (7231), sh (7216), workbook (6751), ピー (6380), コピ (6252), ック (6129), 年度 (6110), scripting (6083), ォル (5845), シー (5840), dictionary (5484), ルダ (5005), 規ブ (4930), dic (4826), name (4709), ート (4644)
- 『複数ブックからシートを抽出する方法』（ドラえもん）
バージョン2010 いつもお世話になっております。 大量のブックから必要な施設の一覧表を参考に新しいブックに検索したシートをコピーすることはできますか? また、そのコピーして手を加えた施設データをコピー元の施設データに上書き??をすることはできますか? 施設ごとにシートを作っています。 膨大な数になる為ブックは施設のふりがな別に分けております。 その年度によって集計、修正する施設の数は決まっておりません。 シート名は施設名になっております。 検索閲覧のみの場合は、目次のブックにハイパーリンクを付けてそのシートに飛べるようにしたいと考えているんですが。 年度ごとに指定される施設が異なり、指定される施設のデータを提出しなくてはならないのです。 どうか、お知恵をお貸しください。 宜しくお願いいたします。 -------------------------------------------------------------------------------- 回答するなら、【はい。できます。たぶん】ということになる。 でも、具体的にどうするかは回答できないね。具体的な要件がまったく提示・説明されていないので。 あと、表現として、【ブック】と【シート】は、明確に区別しようね。 『目次のブック』というと、本当に、目次だけのシートをもった、別のブックがあるように思えるけど そうなのかな? また、『大量のブック』という表現も読む人によって、【たくさんのブック】と理解する人と 【1つのブックでシートがたくさんあるもの】と理解する人もいる。 また、『目次』とか『一覧表』というのは、どのブックのどのシートで、そのレイアウトはどうなっているのか、 そういったことも説明しないとね。 （もちろん、レイアウトの説明は、シートに施設名が記述されています なんてものじゃなく たとえば A1から始まるA列に名前が列挙されていますとか、そういった具体的な説明） (ぶらっと) -------------------------------------------------------------------------------- ぶらっとさん、コメントいつもありがとうございます。 コメント入力中にぶらっとさんから追加コメントもいただき、ありがとうございました。 そしてご指摘ありがとうございます（^0^） 文章能力が乏しく失礼致しました。 これから気を付けて明記したいとおもいます（^0^） ・同じフォルダにふりがな分けしたブック（あ〜わの10個）と、その他施設の区分が違うブックが11個あります。 ・それぞれのシート名は施設名になっております。（フォーマットは同じです） ・毎年ランダムで施設が選ばれて作業をしますが、膨大なシートの中から施設シートを探して一つずつコピーしてくるのが大変です。 その年度に選ばれた施設の一覧表を作成して、その表にある施設名のシートを新しいブックにコピーしたいです。 また、新しいブックにコピーした施設シートは後ほど更新されるので、それをコピー元に上書きしたいです。 ランダムに選ばれた施設名の一覧表は目次という名前でブックになっており、A列に順番に施設名が入力されております。（数は年によってまちまちです） それを使用してA列の順番通りに施設シートを抽出していきたいです。 各施設のシートにはA1〜J22まで書式を含むデーターが入っております。（すべて同じフォーマット） 説明が下手ですみません。 宜しくお願いいたします。 （どらえもん） -------------------------------------------------------------------------------- 何度もすみません。 年度ごとの施設の一覧表ですが、目次というブックに入っております。 シート名は年度毎に H17 や H20 という名前です。 毎年毎年の施設の一覧表を目次というブックに格納していこうと思っています。 A1セルからA列に順番に施設名が入っております。 宜しくお願いいたします （ドラえもん） -------------------------------------------------------------------------------- 考え方としては、選択された年度シートに存在する施設名の頭文字を持つブック（およびその他施設ブック）を 対象にするといいんだろうけど、必ずしも、そうなっていないケースも想定されるので、フォルダ内の全てのブックを 対象にした。新規にまとめあげたブックは、とりあえず、マクロ終了後、新規ブックのまま、エクセル上に残してある。 なお、このマクロは、目次ブックに書くことを想定。 Sub Sample() Dim shn As String Dim sh As Worksheet Dim dic As Object Dim c As Range Dim myPath As String Dim fName As String Dim wb As Workbook Dim nb As Workbook Set dic = CreateObject("Scripting.Dictionary") Do shn = Application.InputBox("処理年度を、Hnn で指定してください。", "処理年度の指定", Format(Date, "ge"), Type:=2) If shn = "False" Then Exit Sub Set sh = Nothing On Error Resume Next Set sh = ThisWorkbook.Sheets(shn) On Error GoTo 0 If Not sh Is Nothing Then Exit Do MsgBox "シート " & shn & " はありません" Loop With sh For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) dic(c.Value) = True Next End With Application.ScreenUpdating = False myPath = "c:¥TEST¥" 'フォルダパスは実際のものを fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name Then '念のため Set wb = Workbooks.Open(myPath & fName) For Each sh In wb.Worksheets If dic.exists(sh.Name) Then If Not nb Is Nothing Then sh.Copy After:=nb.Sheets(nb.Sheets.Count) Else sh.Copy Set nb = ActiveWorkbook End If End If Next wb.Close False End If fName = Dir() Loop Application.ScreenUpdating = True If nb Is Nothing Then MsgBox "対象施設はありませんでした" Else '必要なら新規ブックを保存して閉じる MsgBox "処理終了" End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 今マクロを組んで試したところ、目次の施設が全て新しい【ブック】にコピーされました。 ありがとうございます!! 問題がありまして、新しく【ブック】にコピーされた施設の【シート】の順番が目次の順番になっていないのです。 A1せるからA列に列挙してある順番にシートを並び替えたいのですが、作成していただいたVBAにそれも組むことできますか? それとも新しい【ブック】に目次のシートをコピーしてきてから処理するしかないですか? （ドラえもん） -------------------------------------------------------------------------------- 追加部分は少ないけどフルセット以下。 なお、最初のアップでコメントしていないんだけど、この処理を行うと仮に 施設A が対象で かつ、複数のブックに 施設Aが存在していた場合、施設A 施設A(2) 施設A(3) といったようなシートが出来上がる。 これらも、目次順に並び替えるのもできるけど面倒なので、あくまで目次にあるシート名のみを並び替え。 施設A(2) 施設A(3) といったものがあれば、ブックのの左側に、そのまま残り、そのあとに『並び替えられた正規シート』 を配置する。 Sub Sample2() Dim shn As Variant Dim sh As Worksheet Dim dic As Object Dim c As Range Dim myPath As String Dim fName As String Dim wb As Workbook Dim nb As Workbook Set dic = CreateObject("Scripting.Dictionary") Do shn = Application.InputBox("処理年度を、Hnn で指定してください。", "処理年度の指定", Format(Date, "ge"), Type:=2) If shn = "False" Then Exit Sub Set sh = Nothing On Error Resume Next Set sh = ThisWorkbook.Sheets(shn) On Error GoTo 0 If Not sh Is Nothing Then Exit Do MsgBox "シート " & shn & " はありません" Loop With sh For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) dic(c.Value) = False Next End With Application.ScreenUpdating = False myPath = "c:¥TEST¥" 'フォルダパスは実際のものを fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name Then '念のため Set wb = Workbooks.Open(myPath & fName) For Each sh In wb.Worksheets If dic.exists(sh.Name) Then If Not nb Is Nothing Then sh.Copy After:=nb.Sheets(nb.Sheets.Count) Else sh.Copy Set nb = ActiveWorkbook End If dic(sh.Name) = True End If Next wb.Close False End If fName = Dir() Loop Application.ScreenUpdating = True If nb Is Nothing Then MsgBox "対象施設はありませんでした" Else For Each shn In dic If dic(shn) Then nb.Sheets(shn).Move After:=nb.Sheets(nb.Sheets.Count) Next '必要なら新規ブックを保存して閉じる MsgBox "処理終了" End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 早速試してみたところ、完璧です（^0^）!!! ぶらっとさんが心配してしてくれた A施設のシートの重複の件ですが、施設に1シートと決まっているためその点は大丈夫です!! いつもいつもありがとうございます!! とても助かっています（^0^） また何かありましたら宜しくお願いいたします。 （ドラえもん） -------------------------------------------------------------------------------- すみません。聞き漏れがありました。 シートの上書きについて質問させてください。 必要な施設のシートを新しいブックにコピーした後、更新したのち元のシートに上書きしたいのですが、そのようなこともできますか。 それともう一つ、現在元の施設のシートを作成するにあたって昔に作った施設のシートの内容をコピーしております。 昔作った施設のシートを現在作成中の元の施設シートに自動でコピーできますか? ・転記するシートのセルB5:G12を転記元のB5:G12に、転記するシートのセルK5:L12を転記 元のL5:M12にコピーしたいです。 ・場合によってはコピーする場所が変わるので、コピーする範囲を指定できればなお嬉しいです。 ・現在作成中の元の施設シートにコピーする昔作成した施設シートの名前は同じ ・現在作成中の元の施設シートにあって、昔作成した施設シートがない場合があります（年度によって違う）。 ・現在作成中の元の施設シートは同じフォルダで何個かのブックにわかれております。昔作成した施設シートはひとつのブックに入っております。 宜しくお願いいたします。 （ドラえもん） -------------------------------------------------------------------------------- わかりにくい質問文ですみません。 現在作成中の元の施設シートというのは前回質問させていただいた時の、 同じフォルダにふりがな分けしたブック（あ〜わの10個）と、その他施設の区分が違うブックが11個あります。←これです。 ↑これに、各年に選ばれた施設シートの内容をコピーしたいです。 宜しくお願いいたします （ドラえもん） -------------------------------------------------------------------------------- 追加質問内容は、まだよく読んでいないんだけど、 >必要な施設のシートを新しいブックにコピーした後、更新したのち元のシートに上書きしたい Sample2 は、特定のフォルダ内のブックのシートのうち、目次で指定されたシートを【そのまま】ひっぱってきて 新規ブックにしているだけ。 なので、元のシートと、新しくできたシートは、まったく同じもの。 なのに、【元シートに上書き】?? 同じ内容なのに?? >昔作った施設のシートを現在作成中の元の施設シートに自動でコピーできますか うん。できるよ。 ★もう少し質問や、前スレの要件を復習してみるので、少し時間ください。 でも、↑ の疑問点には回答してね。 (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 いつもお世話になっております（^0^） いつも質問がわかりずらくて申し訳ございません。 ぶらっと様の疑問点について回答させていただきます。 元のシート（特定のフォルダ内のブックのシート）は全施設の閲覧・保存用にと思っています。 このフォルダには全施設のシートが入っております（1000施設ぐらい） この中で毎年200施設ぐらいランダムで選ばれてその施設の状況などを調べています。 前回作っていただいたsample2はこの全施設のフォルダから目次を元に、今年度の施設をコピーしていただいています。 なぜそれが必要かというと、そのコピーした施設だけでその年の状況などを記入したり、そしてそれをデーターにて提出したりする必要があるからなのです。 sample2でこの作業は出来上がるのですが、元のシートを全施設の閲覧・保存用にしたいと思っているので、 そこに新規ブックで編集した施設シートを元のシートに上書きしたいのです。 説明が下手でごめんなさい。。 もし不可解なところがありましたらおっしゃってください。 どうぞ、よろしくお願い致します。 （ドラえもん） -------------------------------------------------------------------------------- 追加説明含めて、少し時間くださいね。 とりあえず、昔のブックからのコピーを。 ★部分、説明の転記元、転記先の表現がちょっとあいまいなので、もしかしたら方向が逆かも。 そこは、そちらで判断してね。 新規ブックに以下を書いて、昔のブックを開いた状態で実行。 コードを書いただけで、まったく動かしていないのでバグあればご容赦。 Sub シートのコピー() Dim bkOld As Workbook Dim bkNew As Workbook Dim sh As Worksheet Dim fName As String Dim myPath As String Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '現在作成中のブックが入っているフォルダ Set bkOld = Workbooks("昔作ったブック.xls") For Each sh In bkOld.Workbooks dic(sh.Name) = True Next fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 Set bkNew = Workbooks.Open(myPath & fName) For Each sh In bkNew.Worksheets If dic.exists(sh.Name) Then sh.Range("B5:G12").Value = bkOld.Sheets(sh.Name).Range("B5:G12").Value sh.Range("L5:M12").Value = bkOld.Sheets(sh.Name).Range("K5:L12").Value '★ End If Next bkNew.Close True fName = Dir() Loop End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます（^0^） 早速実行してみたいと思います!! 色々とありがとうございます。 引き続き、宜しくお願いいたします。 （ドラえもん） -------------------------------------------------------------------------------- やはり、よくわからない。 たとえば、フォルダに ブックX と ブックY が以下のようにあったとする。 ブックX シート 施設A シート 施設B ブックY シート 施設C シート 施設D で、目次で施設Aと施設C が指定されたとすると 新規ブック シート 施設A シート 施設C こんなブックができあがる。 この時、ブックXの施設A と新規ブックの施設A は、全く同じもの。 また、ブックYの施設C と新規ブックの施設C は、全く同じもの。 なので、上書きして書き戻す必要は全くない。 ただ、もし、この新規で作成されたブックの 施設A や 施設C に対して追加書き込みなどをして 変更していれば、それぞれのシートを元のブックに書き戻すという意味はある。そういうこと? そうであれば、アップしたシートコピーのコードを、ほぼ、そのまま使えると思うけど。 アップしたシートコピーは、コピー領域を2ヶ所に絞っているけど、シートのセル全てをコピペするように 変更すればいいだけ。 (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 →ただ、もし、この新規で作成されたブックの 施設A や 施設C に対して追加書き込みなどをして 変更していれば、それぞれのシートを元のブックに書き戻すという意味はある。そういうこと? こういうことです（^0^） 追加で状況を書き込むので書き戻ししたいのです。 コピー領域の部分をそのつど選べるようにできますか?? コピーする部分、それを上書きする部分をVBAの修正なしで選択できたらうれしいのですが（^0^） 難しいでしょうか??? （ドラえもん） -------------------------------------------------------------------------------- ブック毎、シート毎に、領域が異なるということなら面倒だけど。（できないことはないよ。運用が面倒なだけ） どのシートも同じ領域を書き戻すということなら、それはそれで、わりあいと簡単な運用でできるかな。 (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます（^0^） どのシートも同じ領域にしようと思っています。 できればそんな形で宜しくお願いいたします。 （ドラえもん） -------------------------------------------------------------------------------- 書いてみたので試して。 マクロブックにシートを1枚追加。名前はなんでもいいけど、以下のコードでは "コピー指定" にしてある。 最終的には、このシートは非表示でもok。 A列に、コピーしたい元領域を、たとえば A1:C10 といったように記入。B列にコピー先の領域の左上隅のセルを、たとえば F30 といったように記入。 何行でも好きなだけ。 ここを変更すれば、マクロコードを変更しなくても、処理ができる。 最初にダイアログがでるので、新規に作成した例の提出用ブックを選択する。 Sub CopyBack() Dim myPath As String Dim c As Range Dim bk1 As Workbook Dim bk2 As Workbook Dim dicSh As Object Dim dicCell As Object Dim w As Variant Dim todo As Boolean Dim sh As Worksheet Dim fName As String Dim ff As Variant 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "コピーしたいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン Application.ScreenUpdating = False Set bk1 = Workbooks.Open(ff) Set dicSh = CreateObject("Scripting.Dictionary") Set dicCell = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '★元ブックが入っているフォルダ 'コピー元ブックのシート名を格納 For Each sh In bk1.Worksheets dicSh(sh.Name) = True Next 'コピー領域情報を格納 With ThisWorkbook.Sheets("コピー指定") For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) If TypeName(Evaluate(c.Value)) = "Range" And TypeName(Evaluate(c.Offset(, 1).Value)) = "Range" Then dicCell(c.Value) = c.Offset(, 1).Value End If Next End With fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name And fName <> bk1.Name Then Set bk2 = Workbooks.Open(myPath & fName) todo = False For Each sh In bk2.Worksheets If dicSh.exists(sh.Name) Then todo = True For Each w In dicCell With bk1.Sheets(sh.Name).Range(w) sh.Range(dicCell(w)).Resize(.Rows.Count, .Columns.Count).Value = .Value End With Next End If Next bk2.Close todo End If fName = Dir() Loop bk1.Close False Application.ScreenUpdating = True MsgBox "コピーが完了しました" End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます（^0^） 只今試した見たところ、コピーが完了しました。とメッセージボックスが出るのですが、コピーがされません。 あと、ひとつお願い名のですが、シート名が微妙に違うときがあってコピーすることができないシート名を一覧で表示することもできますか??? それは手入力で入れるしかないと思いまして。。。 （ドラえもん） -------------------------------------------------------------------------------- >只今試した見たところ、コピーが完了しました。とメッセージボックスが出るのですが、コピーがされません。 こちらの回答にたいして、『できません』というコメントをもらうことは、この種の掲示板では少なくないね。 もちろん、提示したコードが不備ということはおおいにありうるんだけど、こちらでアップ前に動かして 一応の確認はしている。でも、『できません』ということは、コードで想定しているシートのデータと、その実態がっているんだろうね。 こちらからは、そちらの状態が見えないわけだから、そこは、まずは、そちらで、なぜうまくいかないかを できる限り追求して欲しいね。 考えられるとすれば、たとえば"コピー指定"シートの A列、B列に記述したセル情報が正しくないとか。 そちらで記入した内容を、マウスで選択してコピーして、この掲示板に貼り付けてくれないかな? あとは、ステップ実行ってわかるかな? たとえば For Each sh In bk2.Worksheets にブレークポイントを設定しておき、実行して、ここでとまったら あとは F8 をおして、ステップ実行。コードが、どのような順序で実行されているか、されていないか、 その動きを調べて連絡してくれれば、原因の検討もしやすいねぇ。 >あと、ひとつお願い名のですが、シート名が微妙に違うときがあってコピーすることができないシート名を一覧で表示することもできますか??? これについては、コピーがうまくいってから、考えよう。 1つずつ、つぶしていこうね。 (ぶらっと) -------------------------------------------------------------------------------- 追記） Sub シートのコピー() これはどうだった? (ぶらっと) -------------------------------------------------------------------------------- アップした CopyBack とロジックはかわらないけど、少しメッセージを追加・変更している。 ↑でお願いした、そちらでの原因追及努力に加えて、これを実行して、メッセージがどうでるか確認してくれるかな? Sub CopyBack2() Dim myPath As String Dim c As Range Dim bk1 As Workbook Dim bk2 As Workbook Dim dicSh As Object Dim dicCell As Object Dim w As Variant Dim todo As Boolean Dim sh As Worksheet Dim fName As String Dim ff As Variant Dim bkCnt As Long 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "コピーしたいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン Application.ScreenUpdating = False Set bk1 = Workbooks.Open(ff) Set dicSh = CreateObject("Scripting.Dictionary") Set dicCell = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '★元ブックが入っているフォルダ 'コピー元ブックのシート名を格納 For Each sh In bk1.Worksheets dicSh(sh.Name) = True Next 'コピー領域情報を格納 With ThisWorkbook.Sheets("コピー指定") For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) If TypeName(Evaluate(c.Value)) = "Range" And TypeName(Evaluate(c.Offset(, 1).Value)) = "Range" Then dicCell(c.Value) = c.Offset(, 1).Value Else MsgBox "このセル指定は間違っています " & c.Value & " / " & c.Offset(, 1).Value End If Next End With fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name And fName <> bk1.Name Then Set bk2 = Workbooks.Open(myPath & fName) todo = False For Each sh In bk2.Worksheets If dicSh.exists(sh.Name) Then todo = True For Each w In dicCell With bk1.Sheets(sh.Name).Range(w) sh.Range(dicCell(w)).Resize(.Rows.Count, .Columns.Count).Value = .Value End With Next End If Next bk2.Close todo If todo Then bkCnt = bkCnt + 1 End If fName = Dir() Loop bk1.Close False Application.ScreenUpdating = True If bkCnt Then MsgBox bkCnt & " ブックに対してコピーが完了しました" Else MsgBox "コピーされたブックはありません" End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 おはようございます!! 只今試した見たところ、コピーが完了しました。とメッセージボックスが出るのですが、コピーがされません。 ↑すみませんでした。確かにそんなことだけ言われてもわからないよ〜!って感じですね!!! ごめんなさい。もう少しどんな状況だったとか、どんなデーターを入れていたとかそういうところもきちんと書きたいと思います。 いつも優しいご指導ご鞭撻をありがとうございます!感謝しております。 さて、また新たなVBAを考えて頂いてありがとうございました（^0^） ご指導通り、ブレークポイントを設定してステップインしたところ For Each sh In bk1.Worksheets dicSh(sh.Name) = True ← Next ← 矢印の部分を行ったり来たりしていました!! どうしてかわからないのですが、そのコピー指定のブックを元の施設のフォルダに入れて操作していたのですが、試しにコピー指定のブックをデスクトップに移動して同じ操作をしてみたところ、なんとできました（^0^）!! ↑でも、なぜこのブックを移動するとできるんでしょうか?なんとなく出してみてうまくいきましたが、なぜだか原因はわかりません。 すみません!質問攻めをしてしまったのでシートのコピーのVBAを可動するのを忘れてしまいました!!! せっかく作っていただいのにすみません!! 今可動してみたところ、 Set bkOld = Workbooks("昔作ったブック.xls") For Each sh In bkOld.Workbooks ← dic(sh.Name) = True 矢印の部分で止まってしまって、workbooksをworksheetsにしたらきちんと動きました!! なので大丈夫です（^0^） ありがとうございました!! 引き続きご指導宜しくお願いいたします（^0^） （ドラえもん） -------------------------------------------------------------------------------- まず、ブレークポイントを設定してみたらどうかなと思った場所は For Each sh In bk2.Worksheets そちらでセットした場所は For Each sh In bk1.Worksheets >でも、なぜこのブックを移動するとできるんでしょうか?なんとなく出してみてうまくいきましたが、なぜだか原因はわかりません。 不思議だねぇ。もう少し、調べてみるけど、一応、フォルダ内のブックの内、マクロブックと、コピー元ブックは（もしあっても）除外している。 >workbooksをworksheetsにしたらきちんと動きました!! シートのコピー については、申しわけなかった。お恥ずかしい。ペコリ! (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございました（^0^） ごめんなさい。指示していただいた場所と違った場所でブレークポイントを設定してしまいました!!! もう一度、フォルダ内に入れてブレークポイントを変更して実行してみたいと思います。 そんなそんな!!!こちらこそいつも下手な質問で申し訳ありませ〜ん!! 引き続き、 ⇒あと、ひとつお願い名のですが、シート名が微妙に違うときがあってコピーすることができないシート名を一覧で表示することもできますか??? 宜しくお願いいたします（^0^） （ドラえもん） -------------------------------------------------------------------------------- コピー元にあって、コピーをすることができなかったシートがあれば最後に列挙。 それと、こちらで、コピー元ブックを、コピー先ブックがある同じフォルダにいれて実行したけど問題なく 実行はされたよ? Sub CopyBack3() Dim myPath As String Dim c As Range Dim bk1 As Workbook Dim bk2 As Workbook Dim dicSh As Object Dim dicCell As Object Dim w As Variant Dim todo As Boolean Dim sh As Worksheet Dim fName As String Dim ff As Variant 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "コピーしたいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン Application.ScreenUpdating = False Set bk1 = Workbooks.Open(ff) Set dicSh = CreateObject("Scripting.Dictionary") Set dicCell = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '★元ブックが入っているフォルダ 'コピー元ブックのシート名を格納 For Each sh In bk1.Worksheets dicSh(sh.Name) = True Next 'コピー領域情報を格納 With ThisWorkbook.Sheets("コピー指定") For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) If TypeName(Evaluate(c.Value)) = "Range" And TypeName(Evaluate(c.Offset(, 1).Value)) = "Range" Then dicCell(c.Value) = c.Offset(, 1).Value Else MsgBox "このセル指定は間違っています " & c.Value & " / " & c.Offset(, 1).Value End If Next End With fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name And fName <> bk1.Name Then Set bk2 = Workbooks.Open(myPath & fName) todo = False For Each sh In bk2.Worksheets If dicSh.exists(sh.Name) Then todo = True dicSh.Remove sh.Name For Each w In dicCell With bk1.Sheets(sh.Name).Range(w) sh.Range(dicCell(w)).Resize(.Rows.Count, .Columns.Count).Value = .Value End With Next End If Next bk2.Close todo End If fName = Dir() Loop bk1.Close False Application.ScreenUpdating = True If dicSh.Count = 0 Then MsgBox "全てのシートがコピーされました" Else MsgBox "以下のシートはコピー先がありませんでした" & vbLf & Join(dicSh.keys, vbLf) End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます!! そうですか。私も同じように同じフォルダに入れて試してみます!! その都度また連絡いたします（^0^） （ドラえもん） -------------------------------------------------------------------------------- >私も同じように同じフォルダに入れて試してみます!! 今回の CopyBack シリーズに限って言えば、同じフォルダでもいい（はず）だけど、 そもそもの、当初の処理、フォルダ内からブックを『全て』抽出して、そのなかから指定のシートをピックアップする処理では ピックアップしてできあがったブックを同じフォルダに格納すると、次回、ピックアップ処理する際に 困ることになるよ。 同じフォルダにいれておいたほうがいいなら、何かネーミングルールを設定。たとえばピックアップしてできあがったブックは "施設報告_○○○.xls" といったものにしてピックアップ処理（Sample2）では If fName <> ThisWorkbook.Name Then '念のため これを If fName <> ThisWorkbook.Name And Not fName Like "施設報告*" Then '念のため とするとか。 (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます。 確かに、同じフォルダに格納しなければならない理由はありませんので、フォルダの外に出した状態で実行していきたいと思います。 色々とありがとうございます（^0^） またまた質問なんですが、今 Sub Sample2() Dim shn As Variant Dim sh As Worksheet Dim dic As Object Dim c As Range Dim myPath As String Dim fName As String Dim wb As Workbook Dim nb As Workbook Set dic = CreateObject("Scripting.Dictionary") Do shn = Application.InputBox("処理年度を、Hnn で指定してください。", "処理年度の指定", Format(Date, "ge"), Type:=2) If shn = "False" Then Exit Sub Set sh = Nothing On Error Resume Next Set sh = ThisWorkbook.Sheets(shn) On Error GoTo 0 If Not sh Is Nothing Then Exit Do MsgBox "シート " & shn & " はありません" Loop With sh For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) dic(c.Value) = False Next End With Application.ScreenUpdating = False myPath = "c:¥TEST¥" 'フォルダパスは実際のものを fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name Then '念のため Set wb = Workbooks.Open(myPath & fName) For Each sh In wb.Worksheets If dic.exists(sh.Name) Then If Not nb Is Nothing Then sh.Copy After:=nb.Sheets(nb.Sheets.Count) Else sh.Copy Set nb = ActiveWorkbook End If dic(sh.Name) = True End If Next wb.Close False End If fName = Dir() Loop Application.ScreenUpdating = True If nb Is Nothing Then MsgBox "対象施設はありませんでした" Else For Each shn In dic If dic(shn) Then nb.Sheets(shn).Move After:=nb.Sheets(nb.Sheets.Count) Next '必要なら新規ブックを保存して閉じる MsgBox "処理終了" End If End Sub ↑を実行中なんですが、こちらも シート名が微妙に違うときがあってコピーすることができないシート名を一覧で表示することもできますか? ↑ 一覧表にあって元の施設シートにないものを表示することできますか?? 宜しくお願いいたします。 （ドラえもん） -------------------------------------------------------------------------------- 追加したところは少ないけどフルセット。 (アップ後、メッセージの表示を少し変更） Sub Sample3() Dim shn As Variant Dim sh As Worksheet Dim dic As Object Dim c As Range Dim myPath As String Dim fName As String Dim wb As Workbook Dim nb As Workbook Dim v() As String Dim k As Long Set dic = CreateObject("Scripting.Dictionary") Do shn = Application.InputBox("処理年度を、Hnn で指定してください。", "処理年度の指定", Format(Date, "ge"), Type:=2) If shn = "False" Then Exit Sub Set sh = Nothing On Error Resume Next Set sh = ThisWorkbook.Sheets(shn) On Error GoTo 0 If Not sh Is Nothing Then Exit Do MsgBox "シート " & shn & " はありません" Loop With sh For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) dic(c.Value) = False Next End With Application.ScreenUpdating = False myPath = "c:¥TEST¥" 'フォルダパスは実際のものを fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name Then '念のため Set wb = Workbooks.Open(myPath & fName) For Each sh In wb.Worksheets If dic.exists(sh.Name) Then If Not nb Is Nothing Then sh.Copy After:=nb.Sheets(nb.Sheets.Count) Else sh.Copy Set nb = ActiveWorkbook End If dic(sh.Name) = True End If Next wb.Close False End If fName = Dir() Loop Application.ScreenUpdating = True If nb Is Nothing Then MsgBox "対象施設はありませんでした" Else ReDim v(1 To dic.Count) For Each shn In dic If dic(shn) Then nb.Sheets(shn).Move After:=nb.Sheets(nb.Sheets.Count) Else k = k + 1 v(k) = shn End If Next If k > 0 Then ReDim Preserve v(1 To k) MsgBox "以下のシートが見つかりません" & vbLf & Join(v, vbLf) Else MsgBox "指定のすべてのシートを取り込みました" End If '必要なら新規ブックを保存して閉じる End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、コメントありがとうございます（^0^） これでシート名が違って書いてある時も、訂正するのに施設シートが見つけることができるので助かります（^0^）!! 早速実行してみたいとおもいます。 何度もご回答頂きありがとうございます。 （ドラえもん） -------------------------------------------------------------------------------- こんにちは。毎回お世話になっております。作成していただいたVBAで着々と作業をすすめております。 以前作成していただいた Sub シートのコピー() Dim bkOld As Workbook Dim bkNew As Workbook Dim sh As Worksheet Dim fName As String Dim myPath As String Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '現在作成中のブックが入っているフォルダ Set bkOld = Workbooks("昔作ったブック.xls") For Each sh In bkOld.Workbooks dic(sh.Name) = True Next fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 Set bkNew = Workbooks.Open(myPath & fName) For Each sh In bkNew.Worksheets If dic.exists(sh.Name) Then sh.Range("B5:G12").Value = bkOld.Sheets(sh.Name).Range("B5:G12").Value sh.Range("L5:M12").Value = bkOld.Sheets(sh.Name).Range("K5:L12").Value '★ End If Next bkNew.Close True fName = Dir() Loop End Sub ↑こちらのVBAなんですが、こちらにも Sample3 で追加していただいた シートが見つからなかったときに一覧で表示するようにしてほしいのですが。。（^0^） 宜しくお願いいたします。 -------------------------------------------------------------------------------- Sample3 とはちょっと異なった方式だけど、こんな方法もあるかな? Sub シートのコピー2() Dim bkOld As Workbook Dim bkNew As Workbook Dim sh As Worksheet Dim fName As String Dim myPath As String Dim dic As Object Dim dicNG As Object Set dic = CreateObject("Scripting.Dictionary") Set dicNG = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '現在作成中のブックが入っているフォルダ Set bkOld = Workbooks("昔作ったブック.xls") For Each sh In bkOld.Worksheets dic(sh.Name) = True Next fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 Set bkNew = Workbooks.Open(myPath & fName) For Each sh In bkNew.Worksheets If dic.exists(sh.Name) Then sh.Range("B5:G12").Value = bkOld.Sheets(sh.Name).Range("B5:G12").Value sh.Range("L5:M12").Value = bkOld.Sheets(sh.Name).Range("K5:L12").Value Else dicNG(dicNG.Count) = fName & " " & sh.Name End If Next bkNew.Close True fName = Dir() Loop If dicNG.Count > 0 Then MsgBox "以下のシートへのコピーは実行されませんでした" & vbLf & Join(dicNG.Items, vbLf) End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ↑ あっ、コピー先のブックのシートからみて、コピーされなかったものを表示したけど もしかしたら、昔作ったブックから見て、1件もコピーされないシートがあった場合にそれをリストアップ? （1件も・・・と書いたのは、たとえな昔作ったブックのSheet1 は フォルダ内のブックAにはコピーされたけど ブックBにはSheet1がなかったのでコピーされなかったということがありうるので） (ぶらっと) -------------------------------------------------------------------------------- もし昔作ったブックからの視点でコピーされたかどうかを表示するなら Sub シートのコピー3() Dim bkOld As Workbook Dim bkNew As Workbook Dim sh As Worksheet Dim fName As String Dim myPath As String Dim dic As Object Dim d As Variant Set dic = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '現在作成中のブックが入っているフォルダ Set bkOld = Workbooks("昔作ったブック.xls") For Each sh In bkOld.Worksheets dic(sh.Name) = False Next fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 Set bkNew = Workbooks.Open(myPath & fName) For Each sh In bkNew.Worksheets If dic.exists(sh.Name) Then sh.Range("B5:G12").Value = bkOld.Sheets(sh.Name).Range("B5:G12").Value sh.Range("L5:M12").Value = bkOld.Sheets(sh.Name).Range("K5:L12").Value dic(sh.Name) = True End If Next bkNew.Close True fName = Dir() Loop For Each d In dic If dic(d) Then dic.Remove d Next If dic.Count > 0 Then MsgBox "以下のシートからのコピーは実行されませんでした" & vbLf & Join(dic.keys, vbLf) End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ↑は、どのブックに対してシートコピーがされなかったのがわからないので意味がないかも。 以下のほうがいいのかな? Sub シートのコピー4() Dim bkOld As Workbook Dim bkNew As Workbook Dim sh As Worksheet Dim fName As String Dim myPath As String Dim dic As Object Dim d As Variant Dim dicNG As Object Set dic = CreateObject("Scripting.Dictionary") Set dicNG = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '現在作成中のブックが入っているフォルダ Set bkOld = Workbooks("昔作ったブック.xls") fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 Set bkNew = Workbooks.Open(myPath & fName) dic.RemoveAll For Each sh In bkNew.Worksheets dic(sh.Name) = True Next For Each sh In bkOld.Worksheets If dic.exists(sh.Name) Then sh.Range("B5:G12").Value = bkOld.Sheets(sh.Name).Range("B5:G12").Value sh.Range("L5:M12").Value = bkOld.Sheets(sh.Name).Range("K5:L12").Value Else dicNG(dicNG.Count) = fName & "(" & sh.Name & ")" End If Next bkNew.Close True fName = Dir() Loop If dicNG.Count > 0 Then MsgBox "以下のブックに対して( )内のシートはコピーはされませんでした" & vbLf & Join(dicNG.items, vbLf) End If End Sub (ぶらっと) -------------------------------------------------------------------------------- ぶらっと様、いつもコメントありがとうございます。 毎回とても助かってます。 はい!その通りです。昔のシート（コピー元）から見た時、コピーされなかったシートを参照したかったのです。 考えて頂いてありがとうございました。そしてシートの場所もわかるようにしていただいて、とてもありがたいです!! これから実行してみたいと思います（^0^） ありがとうございました （ドラえもん） -------------------------------------------------------------------------------- ぶらっと様。間違えてしまいました。。。 コピーできなかったシートを参照していただきたいのは、こちらのVBAでした（T0T） Sub CopyBack() Dim myPath As String Dim c As Range Dim bk1 As Workbook Dim bk2 As Workbook Dim dicSh As Object Dim dicCell As Object Dim w As Variant Dim todo As Boolean Dim sh As Worksheet Dim fName As String Dim ff As Variant 'ブックの選択 ff = Application.GetOpenFilename("Excelブック,*.xls*", , "コピーしたいブックを選んでください") If ff = False Then Exit Sub 'キャンセルボタン Application.ScreenUpdating = False Set bk1 = Workbooks.Open(ff) Set dicSh = CreateObject("Scripting.Dictionary") Set dicCell = CreateObject("Scripting.Dictionary") myPath = "c:¥TEST¥" '★元ブックが入っているフォルダ 'コピー元ブックのシート名を格納 For Each sh In bk1.Worksheets dicSh(sh.Name) = True Next 'コピー領域情報を格納 With ThisWorkbook.Sheets("コピー指定") For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) If TypeName(Evaluate(c.Value)) = "Range" And TypeName(Evaluate(c.Offset(, 1).Value)) = "Range" Then dicCell(c.Value) = c.Offset(, 1).Value End If Next End With fName = Dir(myPath & "*.xls") Do While Len(fName) > 0 If fName <> ThisWorkbook.Name And fName <> bk1.Name Then Set bk2 = Workbooks.Open(myPath & fName) todo = False For Each sh In bk2.Worksheets If dicSh.exists(sh.Name) Then todo = True For Each w In dicCell With bk1.Sheets(sh.Name).Range(w) sh.Range(dicCell(w)).Resize(.Rows.Count, .Columns.Count).Value = .Value End With Next End If Next bk2.Close todo End If fName = Dir() Loop bk1.Close False Application.ScreenUpdating = True MsgBox "コピーが完了しました" End Sub ↑こちらでした。。。 先ほどのVBAに直接VBAの画面でコピー範囲を訂正すればいいことですが、こちらの方が便利だと思うので。。 （ドラえもん） v ---- 質問一覧から、表示されたり消えたりと不具合がでています。。。。 ぶらっと様、申し訳ありませんがVBAの改修をお願いいたします。 （ドラえもん） ---- ぶらっと様、またまた間違えてしまいました。 すでに作成していただいたものと間違って以前のVBAを貼付けしていたようです。。 すみませんでした。できました（^0^） ありがとうございました。 （どらえもん） ----... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201306/20130613140402.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97063 documents and 608337 words.
訪問者：