Results of 1 - 1 of about 71 for ExecuteExcel4Macro 閉じた｜開いて｜開かず (0.012 sec.)
executeexcel4macro (140), 閉じた (629), 開いて (4904), 開かず (263)
- [[20131127092456]]
- #score: 14119
- @digest: 8feadf16d50745069eeb4a7fb90e0d1b
- @id: 63946
- @mdate: 2013-11-29T05:10:25Z
- @size: 40887
- @type: text/plain
- #keywords: 月用 (638462), 用'! (363192), ケ月 (333136), path1 (243711), executeexcel4macro (183959), ーta (168669), target11 (158693), target9 (149655), target10 (144256), target18 (143149), target13 (143149), target12 (143149), target16 (143149), target14 (143149), target15 (143149), target17 (143149), target19 (143149), target6 (141745), target5 (140134), target7 (140134), target8 (138571), target20 (137984), target4 (129436), target3 (128169), target1 (123565), target2 (95173), 名ta (92832), path2 (85384), 三ヶ (70715), r12c5 (65903), r16c5 (65903), r12c6 (65903)
- 『該当するシート名のデータだけを転記したい』（ふみ）
WindowsXP,Excel2007を使用しています。 「ふみ」という名前のフォルダ内にあるファイルを検索して、 「2ケ月用」、「3ケ月用」という名前のシートのデータを 別のファイルに転記する下記のコードを作ったのですが、 「2ケ月用」、「3ケ月用」という名前のシートが無いファイルの場合、 #REF!を転記してしまいます。 該当するシートが無い場合は転記せず、次のファイル検索をさせたくて、 いろいろやってみたのですが、うまくいきません。 御教示をお願いします。 Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String Const Path = "W:¥ふみ¥ふみ¥" i = 9 buf = Dir(Path & "*.xlsm") Do While buf <> "" Target1 = "'" & Path & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) buf = Dir() Loop Const Path2 = "W:¥ふみ¥ふみ¥" i = i buf = Dir(Path2 & "*.xlsm") Do While buf <> "" Target11 = "'" & Path2 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path2 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path2 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path2 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) buf = Dir() Loop End Sub ---- ふみさん 実際に動かしていないので、本当にそうなるのかは不確かですが（なら書くな〜(>_<)） 調べるExcelファイルについて、 for each Sht in worksheets if sht.name="2ヶ月用” then 〜〜 2ヶ月用の処理 〜〜 exit for elseif sht.name = "3ヶ月用” THEN 〜〜 3ヶ月用の処理 〜〜 exit for endif next sht みたいな形で処理すれば、うまくいくと思いますが... （パオ〜〜ン） 2013/11/27(水) 09:54 ---- パオ〜〜ンさん、ありがとう御座います。 書いて頂いた様なコードを色々とやっていたのですが、 どうしてもループを抜けなかったり反応がなかったりで 困りはてています。（ふみ） （ふみ） 2013/11/27(水) 10:42 ---- ふみさん >書いて頂いた様なコードを色々とやっていたのですが、 >どうしてもループを抜けなかったり反応がなかったりで ループは exit for で抜けるはずですのが... う〜ん、私が分からないことをなさっているのかな〜。 大変失礼しました。 マクロの編集でマクロを開けて、F8を押しながら、1行1行実行し、ウォッチ式で、変数の値を調べると、なぜループを抜けないか、などがわかるかと思います。 こちらは試してごらんになりましたか? （パオ〜〜ン） 2013/11/27(水) 12:10 ---- ふみさん 次の様なマクロではいかがでしょうか? Workbookを開かないと、For each Sht in Worksheets は上手く動いてくれない様なので... （ひょっとすれば、もっと良い方法があるのかも知れませんが） Sub Sample() Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String Path1 = "C:¥Documents and Settings¥32449¥My Documents¥Excelの学校¥" i = 9 buf = Dir(Path1 & "*.xlsm") Do While buf <> "" If buf <> ThisWorkbook.Name Then Workbooks.Open (Path1 & buf) For Each sht In Worksheets If sht.Name = "2ケ月用" Then GoSub 二ヶ月用 End If If sht.Name = "3ケ月用" Then GoSub 三ヶ月用 End If Next sht Workbooks(buf).Close savechanges:=flase End If buf = Dir() Loop Exit Sub 二ヶ月用: Target1 = "'" & Path & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Return 三ヶ月用: Target11 = "'" & Path2 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path2 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path2 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path2 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) Return End Sub （パオ〜〜ン） 2013/11/27(水) 13:41 ---- パオーンさん ありがとう御座います。 書いて頂いたコードを実行してみましたが、 （引数追加とスペル修正後） 私が考えている姿とは合いません。 フォルダ内のファイルを開きにいくのは 困りますし、 アプリケーション定義またはオブジェクト定義の エラーが三ヶ月用のCells(i, 1) = buf のところで出ます。 私もずっといろいろやっているのですが、 うまくいきません。 bufでファイル名を取得した後、2ケ月と3ケ月の どちらのシートが入っているかを判別して それぞれのDo‾Loopに入れたいのですが。 難しいです。 ちなみにひとつのファイル内には、 必ず1シートだけで、 ファイル名は2ケ月用、3ケ月用、4ケ月用の 3種類いずれか限定とする条件をつけます。（ふみ） （ふみ） 2013/11/27(水) 14:36 ---- [[20050630202158]] が参考になりませんか? すみません。色々と不都合がありましたので、マクロをいじりました。 申し訳ありません。 開かないことには、多分シート名は分からないのでは? Sub Sample() Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String win1 = ActiveWorkbook.Name Path1 = "W:¥ふみ¥ふみ¥" i = 9 Application.EnableEvents = False buf = Dir(Path1 & "*.xlsm") Do While buf <> "" If buf <> ThisWorkbook.Name Then Workbooks.Open (Path1 & buf) For Each sht In Worksheets If sht.Name = "2ケ月用" Then GoSub 二ヶ月用 End If If sht.Name = "3ケ月用" Then GoSub 三ヶ月用 End If Next sht Workbooks(buf).Close savechanges:=False End If buf = Dir() Loop Application.EnableEvents = True Exit Sub 二ヶ月用: Target1 = "'" & Path1 & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path1 & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path1 & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path1 & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Windows(buf).Activate Return 三ヶ月用: Target11 = "'" & Path1 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path1 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path1 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path1 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) Windows(buf).Activate Return End Sub （パオ〜〜ン） 2013/11/27(水) 16:31 ---- パオーンさん ごめんなさい、さっきのコメントの中で、 ファイル名では無くシート名を 2ケ月用、3ケ月用、4ケ月用限定にするつもりです。 また、パオーンさんのコードを参考にして 下記のコードを書いてみました。 ファイルを開かず、 不要なシートのデータを転記しなくなったのですが、 2ケ月のファイルが続くと2回目のデータが #REF!になっている様で、原因がわかりません。 また最後にCells(i, 42) = ExecuteExcel4Macro(Target11) のところで「このワークシートの数式に1つまたは複数の 無効な参照が含まれています。有効なパス、ブック、範囲名 およびセル参照が数式に含まれている事を確認して下さい」 と出ます。 原因がわかる様でしたら御教示下さい。（ふみ） Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String Const Path = "W:¥ふみ¥ふみ¥" i = 9 buf = Dir(Path & "*.xlsm") Do While buf <> "" 二ヶ月用: Target1 = "'" & Path & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー If Target1 = "" Then GoSub 三ヶ月用 End If Target2 = "'" & Path & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) buf = Dir() If Target1 = "*" Then GoSub 二ヶ月用 End If 三ヶ月用: Target11 = "'" & Path & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) buf = Dir() Loop End Sub （ふみ） 2013/11/27(水) 16:47 ---- ふみさん Gosubの使い方が、珍しい使い方になっていて... Gosubされたところは、かならず、ReturnでGosubの次へ戻す様にコードします。 それを考えると、 途中からですが.. ただ、Target1をこのように判定に使えるかどうかは、分かりません。 Application.EnableEvents = False buf = Dir(Path & "*.xlsm") Do While buf <> "" Target1 = "'" & Path & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー If Target1 <> "" Then GoSub 二ヶ月用 Else Target1 = "'" & Path & "[" & buf & "]3ケ月用'!R2C17" If Target1 <> "" Then GoSub 三ヶ月用 End If End If buf=dir() Loop Application.EnableEvents = True Exit Sub 二ヶ月用: Target1 = "'" & Path1 & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path1 & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path1 & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path1 & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Windows(buf).Activate Return 三ヶ月用: Target11 = "'" & Path1 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path1 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path1 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path1 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) Windows(buf).Activate Return End Sub （パオ〜〜ン） 2013/11/27(水) 17:05 ---- パオーンさん ありがとう御座います。 真似をしただけなので、Gosubの使い方、めちゃくちゃだったんですね。 今日は時間切れなので、明日、頂いたコードで検証してみます。 最後にCells(i, 42) = ExecuteExcel4Macro(Target11) のところで「このワークシートの数式に1つまたは複数の 無効な参照が含まれています。有効なパス、ブック、範囲名 およびセル参照が数式に含まれている事を確認して下さい」 と出るのは、別のコードで Private Sub Worksheet_Change(ByVal Target As Range) のところが関係している様です。（ふみ） （ふみ） 2013/11/27(水) 17:21 ---- ふみさん Private Sub Worksheet_Change(ByVal Target As Range) などが入ったエクセルを開ける?ときに、そのマクロを動かしたくなければ、 Application.EnableEvents = False を入れます。それで参照したり、開けたりしたエクセルのマクロは動きません。 （パオ〜〜ン） 2013/11/27(水) 17:32 ---- パオ〜ンさん、ありがとう御座います。 Application.EnableEvents = False も明日、やってみます。 また、わからなかったら教えて下さい。 よろしくお願いします。（ふみ） （ふみ） 2013/11/27(水) 17:48 ---- ふみさん やはり、直前に書いたマクロは全くだめです。 ファイルをOPENしたくない理由はなんでしょうか?マクロが走ってしまうから、なら、 Application.EnableEvents = False でそれを押さえていますので、問題ありません。 やはり、以下が良いと思います。 Sub Sample() Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String Path1 = "C:¥Documents and Settings¥32449¥My Documents¥Excelの学校¥" i = 9 buf = Dir(Path1 & "*.xlsm") Do While buf <> "" If buf <> ThisWorkbook.Name Then Workbooks.Open (Path1 & buf) For Each sht In Worksheets If sht.Name = "2ケ月用" Then GoSub 二ヶ月用 End If If sht.Name = "3ケ月用" Then GoSub 三ヶ月用 End If Next sht Workbooks(buf).Close savechanges:=flase End If buf = Dir() Loop Exit Sub 二ヶ月用: Target1 = "'" & Path & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Return 三ヶ月用: Target11 = "'" & Path2 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path2 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path2 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path2 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path2 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path2 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path2 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Cells(i, 1) = buf Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) Return End Sub （パオ〜〜ン） 2013/11/28(木) 09:21 ---- パオ〜〜ンさん、ありがとう御座います。 今日書いて頂いたコードを実行してみましたが、 やはりアプリケーション定義またはオブジェクト定義の エラーが今度は二ヶ月用の Cells(i, 42) = ExecuteExcel4Macro(Target1) のところで出ます。 また、自分のコードに Application.EnableEvents = False と Application.EnableEvents = True を入れて見ましたが、 効果がありません。同じエラーメッセージが出ます。 何より、このコードはそれぞれの日程計画表から日付を転記して、 ひとつのシートに全ての日程計画表の工程を矢印で表していくのですが、 Application.EnableEvents = False を入れると矢印を書かなくなるので、 この方法は使えません。 各ファイルを開いていく事については、好みではありませんが そうしなければシート名を特定出来ないのであれば仕方ないと思います。 私が今書いているコードはシート名を特定しているのではないので、 パオ〜〜ンさんのコードが正しいと思います。 （ふみ） （ふみ） 2013/11/28(木) 13:33 ---- ふみさん すみません。 ちょっと失念がありました。 Cells(i, 42) = ExecuteExcel4Macro(Target11) はエクセルマクロを動かしていらっしゃる様なので、その前後で マクロ動作を許す形にしないとまずいです。 すみません。m(__)m 以下の形ではいかがでしょうか? 環境が違うので、テストが完全にできずに申し訳ありません。 Sub Sample() Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String win1 = ActiveWorkbook.Name Path1 = "W:¥ふみ¥ふみ¥" i = 9 Application.EnableEvents = False buf = Dir(Path1 & "*.xlsm") Do While buf <> "" If buf <> ThisWorkbook.Name Then Workbooks.Open (Path1 & buf) For Each sht In Worksheets If sht.Name = "2ケ月用" Then GoSub 二ヶ月用 End If If sht.Name = "3ケ月用" Then GoSub 三ヶ月用 End If Next sht Workbooks(buf).Close savechanges:=False End If buf = Dir() Loop Application.EnableEvents = True Exit Sub 二ヶ月用: Target1 = "'" & Path1 & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path1 & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path1 & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path1 & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If GoSub 結果書き込み Return 三ヶ月用: Target11 = "'" & Path1 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path1 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path1 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path1 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If GoSub 結果書き込み Return 結果書き込み: Windows(win1).Activate Cells(i, 1) = buf Application.EnableEvents = True Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Application.EnableEvents = False Windows(buf).Activate Return End Sub （パオ〜〜ン） 2013/11/28(木) 15:20 ---- パオ〜〜ンさん 頂いたコードを実行してみました。 走りましたが、転記するシートにでは無く、 フォルダ内の開いたシートに「0」とか「##」とかを書き込んで 次々とシートチェンジするので、 どんな動作をしているのかよくわかりませんが、 うまくいかなかった事は確かです。 最後は私の方でシート保護をかけているので、 Sheets("2ケ月用").Unprotect Password:="****" のところで「インデックスが有効範囲にありません」で止まりました。 テストが出来ない状態で、しかも他のコード内容がわからない状態で 考えて頂いて申し訳ないです。 （ふみ） （ふみ） 2013/11/28(木) 15:47 ---- ふみさん 申し訳ありません。 マクロを走らせているエクセルファイルに書くつもりだったのですが....(>_<) マクロの編集で、このマクロを開いておいて、F8キーを押しながら、1行1行実行してみて頂けませんか? このマクロが入ったエクセルをアクティブにしておいて、動作させると、 win1 = ActiveWorkbook.Name で win1 が このエクセルファイルを指し、 結果書き込みでは、 Windows(win1).Activate で このエクセルファイルをアクティブにするはずなのですが.. すみません。軽く考えすぎた私のミスです。私の力不足でした。 （パオ〜〜ン） 2013/11/28(木) 16:32 ---- パオ〜〜ンさん、ごめんなさい! 頂いたコードに完全に変更せずに実行した事に気付きました。 走らせてみたら、途中までうまくいっている様です。 私が付け足しているシート保護のところでまた止まりましたので、 これを直したらうまくいくかも知れません。 頂いたコードをそのままコピペ出来たら、こんなミスはなかったのですが。。。 実際のコードはTargetも86まであり、そのままコピペ出来ないんです。 本当にごめんなさい。（ふみ） （ふみ） 2013/11/28(木) 16:42 ---- パオ〜〜ンさん シート保護を外して走らせると、今11ファイルありますが、 全て転記しました。 順番的には2ケ月,2,2,3,2,2,2,3,2,2,3ケ月で転記していますが、 ファイル名はちゃんと転記しているのに、データは3ケ月だけ、 直前の2ケ月のデータと全く同じになってしまって2回繰り返しています。 パオ〜〜ンさんのコードは結果書き込みが2ケ月用しかなかったので、 勝手に3ケ月用も同じ様に書き込んだんですが、ここがまずかった? （ふみ） （ふみ） 2013/11/28(木) 17:06 ---- パオ〜〜ンさん 試しに勝手に書き込んだ3ケ月の結果書き込みを消して 実行してみましたが、結果は同じでした。 Targetの番号は一致していなくてもいいんですか? 今日はもう時間切れなので、明日教えて下さい。 よろしくお願いします。（ふみ） （ふみ） 2013/11/28(木) 17:23 ---- ふみさん すみません。2ヶ月と3ヶ月では呼び出しのマクロがちがうのですね。 大変申し訳ないことをしました。ごめんなさい。 もう、本当にご迷惑ばかり掛けて.... これでどうでしょうか?（マクロの意味も右側に入れました） Sub Sample() Dim i As Long, buf As String Dim Target1 As String, Target2 As String Dim Target3 As String, Target4 As String, Target5 As String Dim Target6 As String, Target7 As String, Target8 As String Dim Target9 As String, Target10 As String, Target11 As String Dim Target12 As String, Target13 As String, Target14 As String Dim Target15 As String, Target16 As String, Target17 As String Dim Target18 As String, Target19 As String, Target20 As String win1 = ActiveWorkbook.Name '開いたエクセル（このエクセル）の名前を保存 Path1 = "W:¥ふみ¥ふみ¥" i = 9 Application.EnableEvents = False 'ブックを開けたときのマクロを動作させない buf = Dir(Path1 & "*.xlsm") 'W:¥ふみ¥ふみ のフォルダーにある マクロ付きエクセルファイルをさがす Do While buf <> "" '対象のエクセルファイルがあれば繰り返す If buf <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理 Workbooks.Open (Path1 & buf) '探したエクセルファイルを開けて For Each sht In Worksheets 'そのワークシートについて If sht.Name = "2ケ月用" Then 'シート名が ”2ヶ月用”なら GoSub 二ヶ月用 '二ヶ月用 という サフ へ飛んで処理をして、この次に戻る End If If sht.Name = "3ケ月用" Then 'シート名が ”3ヶ月用”なら GoSub 三ヶ月用 '三ヶ月用 という サフ へ飛んで処理をして、この次に戻る End If Next sht Workbooks(buf).Close savechanges:=False '開いたワークブックを変更を保存しないで閉じる End If buf = Dir() 'W:¥ふみ¥ふみ のフォルダーにある 次のマクロ付きエクセルファイル Loop Application.EnableEvents = True 'ブックを開けたときのマクロを動作させる Exit Sub 二ヶ月用: Target1 = "'" & Path1 & "[" & buf & "]2ケ月用'!R2C17" 'ユーザー Target2 = "'" & Path1 & "[" & buf & "]2ケ月用'!R4C17" '件名 Target3 = "'" & Path1 & "[" & buf & "]2ケ月用'!R6C17" 'オーダー Target4 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C5" Target5 = "'" & Path1 & "[" & buf & "]2ケ月用'!R12C6" Target6 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C5" Target7 = "'" & Path1 & "[" & buf & "]2ケ月用'!R14C6" Target8 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C5" Target9 = "'" & Path1 & "[" & buf & "]2ケ月用'!R16C6" Target10 = "'" & Path1 & "[" & buf & "]2ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate 'このエクセルファイルをアクティブにして Cells(i, 1) = buf Application.EnableEvents = True 'エクセルマクロを稼働させる Cells(i, 42) = ExecuteExcel4Macro(Target1) Cells(i, 43) = ExecuteExcel4Macro(Target2) Cells(i, 44) = ExecuteExcel4Macro(Target3) Cells(i, 2) = ExecuteExcel4Macro(Target4) Cells(i, 3) = ExecuteExcel4Macro(Target5) Cells(i, 4) = ExecuteExcel4Macro(Target6) Cells(i, 5) = ExecuteExcel4Macro(Target7) Cells(i, 6) = ExecuteExcel4Macro(Target8) Cells(i, 7) = ExecuteExcel4Macro(Target9) Cells(i, 8) = ExecuteExcel4Macro(Target10) Application.EnableEvents = False 'エクセルマクロを動かさない Windows(buf).Activate 'Dir コマンドで得たエクセルファイルを アクティブにして Return 三ヶ月用: Target11 = "'" & Path1 & "[" & buf & "]3ケ月用'!R2C18" 'ユーザー Target12 = "'" & Path1 & "[" & buf & "]3ケ月用'!R4C18" '件名 Target13 = "'" & Path1 & "[" & buf & "]3ケ月用'!R6C18" 'オーダー Target14 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C5" Target15 = "'" & Path1 & "[" & buf & "]3ケ月用'!R12C6" Target16 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C5" Target17 = "'" & Path1 & "[" & buf & "]3ケ月用'!R14C6" Target18 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C5" Target19 = "'" & Path1 & "[" & buf & "]3ケ月用'!R16C6" Target20 = "'" & Path1 & "[" & buf & "]3ケ月用'!R18C5" i = i + 3 If i > 53 Then MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。" Exit Sub End If Windows(win1).Activate Cells(i, 1) = buf Application.EnableEvents = True Cells(i, 42) = ExecuteExcel4Macro(Target11) Cells(i, 43) = ExecuteExcel4Macro(Target12) Cells(i, 44) = ExecuteExcel4Macro(Target13) Cells(i, 2) = ExecuteExcel4Macro(Target14) Cells(i, 3) = ExecuteExcel4Macro(Target15) Cells(i, 4) = ExecuteExcel4Macro(Target16) Cells(i, 5) = ExecuteExcel4Macro(Target17) Cells(i, 6) = ExecuteExcel4Macro(Target18) Cells(i, 7) = ExecuteExcel4Macro(Target19) Cells(i, 8) = ExecuteExcel4Macro(Target20) Application.EnableEvents = False Windows(buf).Activate Return End Sub （パオ〜〜ン） 2013/11/29(金) 09:11 ---- パオ〜〜ンさん、おはよう御座います。 朝一番に、昨日頂いたコードの結果書き込みを 結果書き込み1と2に分けて、2ケ月と3ケ月を GoSubさせたら、完全にうまくいく様になりました。 嬉しくてコメントしようとしたら、また新しいコードを 書いて下さったんですね。ありがとう御座います。 こちらの方がシンプルなので、実行してみます。 これであとは4ケ月用も追加して作業を続けようと思います。 問題解決して頂き、本当にありがとう御座いました。 また、自分で解決出来ない事が起きたらお願いしに来ますので、 その時はよろしくお願いします。 ありがとう御座いました。（ふみ） （ふみ） 2013/11/29(金) 09:30 ---- ふみさん 何度も何度も、コードを出して申し訳ありませんでした。 うまく行って、よかった〜。(^^ゞ お手数をおかけしたにも拘わらず、感謝のお言葉まで頂き、恐縮しています。 こちらこそ、ありがとうございました。 （パオ〜〜ン） 2013/11/29(金) 14:10... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201311/20131127092456.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97056 documents and 608292 words.
訪問者：