[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダ内のファイルを並び変えて処理したい。』（ふみ）
こんにちは。
パオ〜〜ンさんに教えて頂いて、フォルダ内のファイルを開いて、
シート名を読み取ってシート名の種類毎に処理をするコードを作りました。
しかし処理をする順番に規則性がなく、一覧表に転記するのですが、
順番がバラバラになってしまうので非常に見にくくなってしまうという
問題が発生してしまいました。
そこで、下記の様にコードを変更しました。しかし、このコードでは
Format(j, "000") & ".xlsm"と完全に一致したファイル名が見つからないと
エラーになってしまいます。
例えばファイル名を「001」、「002」に書き換えておくと、うまくいきますが、
現在のファイル名は「B1-○○○○（４桁の数字）」「B3-○○○○（４桁の数字）」
「B9-○○○○（４桁の数字）」「C8-○○○○（４桁の数字）」が先頭に書いてあって、その後にいろいろな名前が書いてあります。今後も増え続けるファイルを
ずっと書き換えていくのは大変ですので並び換え出来る様にしたいです。
現在のファイル名を昇順に並び換える、あるいは名前を置き換える、等の
処理の仕方がわかりません。
並び換えしたい順番はB1→B3→B9→C8の順です。またファイル名と完全一致ではなく、
その後のいろいろな名前は無視する様にしたいです。
よろしくお願いします。
Dim i As Long
Dim j As Long Dim buf As String 'ファイル名 Dim Path As String Dim sht As Variant Dim win1 As String
win1 = ActiveWorkbook.Name '開いたエクセル（このエクセル）の名前を保存
Dim fc As Long 'ファイル数
buf = Dir("W:\ふみ\ふみ\*.xlsm")
Do While buf <> ""
fc = fc + 1
buf = Dir()
Loop
MsgBox "ファイル数は" & fc & "です。"
For j = 1 To fc - 1
buf = Format(j, "000") & ".xlsm"
Path = "W:\ふみ\ふみ\"
i = 9
Application.EnableEvents = False 'ブックを開けたときのマクロを動作させない
If buf <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
Workbooks.Open (Path & buf) '探したエクセルファイルを開けて
For Each sht In Worksheets 'そのワークシートについて
If sht.Name = "２ケ月用" Then 'シート名が ”２ヶ月用”なら
GoSub 二ヶ月用 '二ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
If sht.Name = "３ケ月用" Then 'シート名が ”３ヶ月用”なら
GoSub 三ヶ月用 '三ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
If sht.Name = "４ケ月用" Then 'シート名が ”４ヶ月用”なら
GoSub 四ヶ月用 '四ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
Next sht
Workbooks(buf).Close savechanges:=False '開いたワークブックを変更を保存しないで閉じる
End If
Next
Application.EnableEvents = True 'ブックを開けたときのマクロを動作させる
Exit Sub
＜ 使用 Excel：Excel2007、使用 OS：WindowsXP ＞
お久しぶりです。(^^ゞ
出てきた結果を並び替える、ではだめなのでしょうか？
フォルダーの中のファイルを並べるのはほぼ無理だと思います。
またファイル名と完全一致ではなく、
その後のいろいろな名前は無視する様にしたいです。
これは buf の調べ方の問題ですね。
例えば、
If buf <> ThisWorkbook.Name Then の次に
If left(buf,2) = "B1" or eft(buf,2) = "B3" or eft(buf,2) = "B9" or eft(buf,2) = "C8" then
を入れると解決しませんか？
（パオ〜〜ン） 2013/12/12(木) 15:20
横やりすみません。
昇順の例です。
もし並べ替える順番が全て決まっていなら、その通りできますけど、４種類じゃないですよね？
Sub ふみ()
Dim j As Long
Dim buf As String 'ファイル名
Dim Path As String
Dim sht As Variant
Dim win1 As String
Dim FN As Variant
win1 = ActiveWorkbook.Name '開いたエクセル（このエクセル）の名前を保存
With CreateObject("System.Collections.ArrayList")
.Add Dir("W:\ふみ\ふみ\*.xlsm")
Do
.Add Dir()
Loop Until .Item(.Count - 1) = ""
.Sort
.removeat 0
Set FN = .Clone
End With
MsgBox "ファイル数は" & FN.Count & "です。"
For j = 1 To FN.Count
'Path = "W:\ふみ\ふみ\" '←これいるの？
Application.EnableEvents = False 'ブックを開けたときのマクロを動作させない
If FN(j) <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
For Each sht In Worksheets 'そのワークシートについて
Select Case sht.Name
Case "２ケ月用" 'シート名が ”２ヶ月用”なら
GoSub 二ヶ月用 '二ヶ月用というサブへ飛んで処理をする
Case "３ケ月用" 'シート名が ”３ヶ月用”なら
GoSub 三ヶ月用 '三ヶ月用というサブへ飛んで処理をする
Case "４ケ月用" 'シート名が ”４ヶ月用”なら
GoSub 四ヶ月用 '四ヶ月用というサブへ飛んで処理をする
End Select
Next sht
Workbooks(FN(j)).Close savechanges:=False '開いたワークブックを変更を保存しないで閉じる
End If
Next
Application.EnableEvents = True 'ブックを開けたときのマクロを動作させる
End Sub
（稲葉） 2013/12/12(木) 15:25
またお世話になります。よろしくお願いします。
If left(buf,2) = "B1" or eft(buf,2) = "B3" or eft(buf,2) = "B9" or eft(buf,2) = "C8" then
を追加してコードを走らせましたが、「SubまたはFunctionが定義されていません」となりました。
eftをLeftに直して走らせたら、エラーは出ませんが、どのファイルも開きません。
ファイル名の左から２文字がB1,B3,B9,C8のいずれかだったら開く、というコードですよね。
それからファイルシステムがＮＴＦＳだったらファイル名を昇順で読みだすと調べたのですが、
今、フォルダを置いているファイルサーバーがＸ○○○（ごめんなさい、思い出せません）で
ＮＴＦＳでは無いので、どの様な規則でファイルを開いていくのかわからないと思いました。
もし、B1,B3,B9,C8が左２文字に入っているファイルだけ開く事が出来たとして、
出てきた結果を並び替え出来ますか？
（ふみ） 2013/12/12(木) 15:59
四ヶ月用というsubがないからそうなります。 そこは変更していないので、こちらだけエラーになるのはおかしいですね。 （稲葉） 2013/12/12(木) 16:43
お詫びと御報告です。
フォルダ内のファイル名を試しに001〜をつけたままでした。
B１−○○○○に直したら、開きにいきましたが、
以前と同じ、規則性のないバラバラの順番でした。
稲葉さん
四ヶ月用: は何も変更していませんし、見直しても三ヶ月用との
違いがありません。でもなにか原因があるはずなので
何回も確認してみます。
（ふみ） 2013/12/12(木) 16:50
>現在のファイル名は「B1-○○○○（４桁の数字）」「B3-○○○○（４桁の数字）」 >B9-○○○○（４桁の数字）」「C8-○○○○（４桁の数字）」が先頭に書いてあって、その後にいろ いろな名前が書いてあります。今後も増え続けるファイルを ずっと書き換えていくのは大変ですので並び換え出来る様にしたいです。
B10-○○○○ とかになる場合もあるのですか？
具体的にどのようなファイル名をどのような順番にしたいのかサンプルがあるとわかりやすいのですが？ （seiya） 2013/12/12(木) 17:02
私の案は、とにかく出してしまって、後で手でソートする、という原始的な案です。
その点稲葉さんのは順番に出てくると思います。
四ヶ月用ののところで「コンパイルエラー、行ラベルが定義されていません」
というのは、多分 四ヶ月用： の前に END SUB があるのではないでしょうか？
（パオ〜〜ン） 2013/12/12(木) 17:27
それだったらArrayListの単純Sortでもできると思いますが？ > GoSub 四ヶ月用 これ GoSub "四ヶ月用" じゃないのかな？ （seiya） 2013/12/12(木) 17:41
あれ？ラベルって""必要ありましたっけ？
使ったことないのでよくわかっていませんが・・・
とりあえず、先に挙げていただいたB1→B3→B9→C8に対応です。
Sub ふみ()
Dim j As Long
Dim buf As String 'ファイル名
Dim Path As String
Dim sht As Variant
Dim win1 As String
Dim FN As Variant
win1 = ActiveWorkbook.Name '開いたエクセル（このエクセル）の名前を保存
With CreateObject("System.Collections.ArrayList")
.Add Dir("W:\ふみ\ふみ\*.xlsm")
Do
.Add Dir()
Loop Until .Item(.Count - 1) = ""
.Sort
.removeat 0
Set FN = .Clone
End With
MsgBox "ファイル数は" & FN.Count & "です。"
Application.EnableEvents = False 'ブックを開けたときのマクロを動作させない
For j = 1 To FN.Count
If Len(Replace("B1B3B9C8", Left(FN(j), 2), "")) < 8 Then
If FN(j) <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
For Each sht In Worksheets 'そのワークシートについて
Select Case sht.Name
Case "２ケ月用" 'シート名が ”２ヶ月用”なら
GoSub 二ヶ月用 '二ヶ月用というサブへ飛んで処理をする
Case "３ケ月用" 'シート名が ”３ヶ月用”なら
GoSub 三ヶ月用 '三ヶ月用というサブへ飛んで処理をする
Case "４ケ月用" 'シート名が ”４ヶ月用”なら
GoSub 四ヶ月用 '四ヶ月用というサブへ飛んで処理をする
End Select
Next sht
Workbooks(FN(j)).Close savechanges:=False '開いたワークブックを変更を保存しないで閉じる
End If
End If
Next
Application.EnableEvents = True 'ブックを開けたときのマクロを動作させる
Exit Sub
'以下サブルーチン
End Sub
（稲葉） 2013/12/12(木) 17:55
GoSub っていうProcedureにString型の変数を渡してるんだと勝手に想像 （seiya） 2013/12/12(木) 18:05
なるほど！ GoSubステートメントしか頭にありませんでした。 もっと柔らかくしないとだめですね。 （稲葉） 2013/12/12(木) 18:07
あれれ、 GoSub ステートメントっていうのは知らなかった.... これで処理するより、別プロシージャに変数渡す処理の方がいいと思うけど... （seiya） 2013/12/12(木) 18:30
それもそうですね。 そうすればメインのプロシジャーは Select文の代わりsht.Nameを引数として渡しちゃえば簡単ですね！
（稲葉） 2013/12/12(木) 18:49
パオ〜〜ンさん、四ヶ月用：の前にEnd Subはありません。Returnです。
seiyaさん、GoSub "四ヶ月用"にすると赤字のエラーになります。
稲葉さん、新しく書いて頂いたコードを試しましたが、やはり
四ヶ月用ののところで「コンパイルエラー、行ラベルが定義されていません」
となります。
seiyaさん、稲葉さん、その後の話は素人の私には何もわかりません。
単純な構成なので、とても長いコードになっていますが、全部載せてみます。
ソートは出来ませんが、問題なく動作しているコードです。
Sub ボタン2_Click()
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
Dim Target21 As String, Target22 As String, Target23 As String
Dim Target24 As String, Target25 As String, Target26 As String
Dim Target27 As String, Target28 As String, Target29 As String
Dim Target30 As String, Target31 As String, Target32 As String
Dim Target33 As String, Target34 As String, Target35 As String
Dim Target36 As String, Target37 As String, Target38 As String
Dim Target39 As String, Target40 As String, Target41 As String
Dim Target42 As String, Target43 As String
Dim Target44 As String, Target45 As String
Dim Target46 As String, Target47 As String, Target48 As String
Dim Target49 As String, Target50 As String, Target51 As String
Dim Target52 As String, Target53 As String, Target54 As String
Dim Target55 As String, Target56 As String, Target57 As String
Dim Target58 As String, Target59 As String, Target60 As String
Dim Target61 As String, Target62 As String, Target63 As String
Dim Target64 As String, Target65 As String, Target66 As String
Dim Target67 As String, Target68 As String, Target69 As String
Dim Target70 As String, Target71 As String, Target72 As String
Dim Target73 As String, Target74 As String, Target75 As String
Dim Target76 As String, Target77 As String, Target78 As String
Dim Target79 As String, Target80 As String, Target81 As String
Dim Target82 As String, Target83 As String, Target84 As String
Dim Target85 As String, Target86 As String
Dim Target87 As String, Target88 As String
Dim Target89 As String, Target90 As String, Target91 As String
Dim Target92 As String, Target93 As String, Target94 As String
Dim Target95 As String, Target96 As String, Target97 As String
Dim Target98 As String, Target99 As String, Target100 As String
Dim Target101 As String, Target102 As String, Target103 As String
Dim Target104 As String, Target105 As String, Target106 As String
Dim Target107 As String, Target108 As String, Target109 As String
Dim Target110 As String, Target111 As String, Target112 As String
Dim Target113 As String, Target114 As String, Target115 As String
Dim Target116 As String, Target117 As String, Target118 As String
Dim Target119 As String, Target120 As String, Target121 As String
Dim Target122 As String, Target123 As String, Target124 As String
Dim Target125 As String, Target126 As String, Target127 As String
Dim Target128 As String, Target129 As String, Target130 As String
Dim Target131 As String, Target132 As String, Target133 As String
Dim Target134 As String, Target135 As String
Dim buf As String Dim i As Long Dim Path As String Dim sht As Variant Dim win1 As String
win1 = ActiveWorkbook.Name '開いたエクセル（このエクセル）の名前を保存
Path = "W:\ふみ\社内（原価・日程）管理表\"
i = 9
Application.EnableEvents = False 'ブックを開けたときのマクロを動作させない
buf = Dir(Path & "*.xlsm") 'W:\ふみ\社内（原価・日程）管理表のフォルダーにあるマクロ付きエクセルファイルをさがす
Do While buf <> "" '対象のエクセルファイルがあれば繰り返す
If buf <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
Workbooks.Open (Path & buf) '探したエクセルファイルを開けて
For Each sht In Worksheets 'そのワークシートについて
If sht.Name = "２ケ月用" Then 'シート名が ”２ヶ月用”なら
GoSub 二ヶ月用 '二ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
If sht.Name = "３ケ月用" Then 'シート名が ”３ヶ月用”なら
GoSub 三ヶ月用 '三ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
If sht.Name = "４ケ月用" Then 'シート名が ”４ヶ月用”なら
GoSub 四ヶ月用 '四ヶ月用というサブへ飛んで処理をして、この次に戻る
End If
Next sht
Workbooks(buf).Close savechanges:=False '開いたワークブックを変更を保存しないで閉じる
End If
buf = Dir() 'W:\ふみ\社内（原価・日程）管理表のフォルダーにある 次のマクロ付きエクセルファイル
Loop
Application.EnableEvents = True 'ブックを開けたときのマクロを動作させる
Exit Sub
二ヶ月用:
Target1 = "'" & Path & "[" & buf & "]２ケ月用'!R1C17" 'ユーザー
Target2 = "'" & Path & "[" & buf & "]２ケ月用'!R3C17" '件名
Target3 = "'" & Path & "[" & buf & "]２ケ月用'!R5C17" 'オーダー
Target130 = "'" & Path & "[" & buf & "]２ケ月用'!R7C17" '売価
Target131 = "'" & Path & "[" & buf & "]２ケ月用'!R7C38" 'ＧＰ額
Target4 = "'" & Path & "[" & buf & "]２ケ月用'!R12C5"
Target5 = "'" & Path & "[" & buf & "]２ケ月用'!R12C6"
Target6 = "'" & Path & "[" & buf & "]２ケ月用'!R14C5"
Target7 = "'" & Path & "[" & buf & "]２ケ月用'!R14C6"
Target8 = "'" & Path & "[" & buf & "]２ケ月用'!R16C5"
Target9 = "'" & Path & "[" & buf & "]２ケ月用'!R16C6"
Target10 = "'" & Path & "[" & buf & "]２ケ月用'!R18C5"
Target11 = "'" & Path & "[" & buf & "]２ケ月用'!R18C6"
Target12 = "'" & Path & "[" & buf & "]２ケ月用'!R20C5"
Target13 = "'" & Path & "[" & buf & "]２ケ月用'!R20C6"
Target14 = "'" & Path & "[" & buf & "]２ケ月用'!R22C5"
Target15 = "'" & Path & "[" & buf & "]２ケ月用'!R22C6"
Target16 = "'" & Path & "[" & buf & "]２ケ月用'!R24C5"
Target17 = "'" & Path & "[" & buf & "]２ケ月用'!R24C6"
Target18 = "'" & Path & "[" & buf & "]２ケ月用'!R26C5"
Target19 = "'" & Path & "[" & buf & "]２ケ月用'!R26C6"
Target20 = "'" & Path & "[" & buf & "]２ケ月用'!R28C5"
Target21 = "'" & Path & "[" & buf & "]２ケ月用'!R28C6"
Target22 = "'" & Path & "[" & buf & "]２ケ月用'!R30C5"
Target23 = "'" & Path & "[" & buf & "]２ケ月用'!R30C6"
Target24 = "'" & Path & "[" & buf & "]２ケ月用'!R32C5"
Target25 = "'" & Path & "[" & buf & "]２ケ月用'!R32C6"
Target26 = "'" & Path & "[" & buf & "]２ケ月用'!R34C5"
Target27 = "'" & Path & "[" & buf & "]２ケ月用'!R34C6"
Target28 = "'" & Path & "[" & buf & "]２ケ月用'!R36C5"
Target29 = "'" & Path & "[" & buf & "]２ケ月用'!R36C6"
Target30 = "'" & Path & "[" & buf & "]２ケ月用'!R38C5"
Target31 = "'" & Path & "[" & buf & "]２ケ月用'!R38C6"
Target32 = "'" & Path & "[" & buf & "]２ケ月用'!R40C5"
Target33 = "'" & Path & "[" & buf & "]２ケ月用'!R40C6"
Target34 = "'" & Path & "[" & buf & "]２ケ月用'!R42C5"
Target35 = "'" & Path & "[" & buf & "]２ケ月用'!R42C6"
Target36 = "'" & Path & "[" & buf & "]２ケ月用'!R44C5"
Target37 = "'" & Path & "[" & buf & "]２ケ月用'!R44C6"
Target38 = "'" & Path & "[" & buf & "]２ケ月用'!R46C5"
Target39 = "'" & Path & "[" & buf & "]２ケ月用'!R46C6"
Target40 = "'" & Path & "[" & buf & "]２ケ月用'!R48C5"
Target41 = "'" & Path & "[" & buf & "]２ケ月用'!R48C6"
Target42 = "'" & Path & "[" & buf & "]２ケ月用'!R50C5"
Target43 = "'" & Path & "[" & buf & "]２ケ月用'!R50C6"
i = i + 3
If i > 71 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 + 1, 44) = ExecuteExcel4Macro(Target130)
Cells(i + 2, 44) = ExecuteExcel4Macro(Target131)
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)
Cells(i, 9) = ExecuteExcel4Macro(Target11)
Cells(i, 10) = ExecuteExcel4Macro(Target12)
Cells(i, 11) = ExecuteExcel4Macro(Target13)
Cells(i, 12) = ExecuteExcel4Macro(Target14)
Cells(i, 13) = ExecuteExcel4Macro(Target15)
Cells(i, 14) = ExecuteExcel4Macro(Target16)
Cells(i, 15) = ExecuteExcel4Macro(Target17)
Cells(i, 16) = ExecuteExcel4Macro(Target18)
Cells(i, 17) = ExecuteExcel4Macro(Target19)
Cells(i, 18) = ExecuteExcel4Macro(Target20)
Cells(i, 19) = ExecuteExcel4Macro(Target21)
Cells(i, 20) = ExecuteExcel4Macro(Target22)
Cells(i, 21) = ExecuteExcel4Macro(Target23)
Cells(i, 22) = ExecuteExcel4Macro(Target24)
Cells(i, 23) = ExecuteExcel4Macro(Target25)
Cells(i, 24) = ExecuteExcel4Macro(Target26)
Cells(i, 25) = ExecuteExcel4Macro(Target27)
Cells(i, 26) = ExecuteExcel4Macro(Target28)
Cells(i, 27) = ExecuteExcel4Macro(Target29)
Cells(i, 28) = ExecuteExcel4Macro(Target30)
Cells(i, 29) = ExecuteExcel4Macro(Target31)
Cells(i, 30) = ExecuteExcel4Macro(Target32)
Cells(i, 31) = ExecuteExcel4Macro(Target33)
Cells(i, 32) = ExecuteExcel4Macro(Target34)
Cells(i, 33) = ExecuteExcel4Macro(Target35)
Cells(i, 34) = ExecuteExcel4Macro(Target36)
Cells(i, 35) = ExecuteExcel4Macro(Target37)
Cells(i, 36) = ExecuteExcel4Macro(Target38)
Cells(i, 37) = ExecuteExcel4Macro(Target39)
Cells(i, 38) = ExecuteExcel4Macro(Target40)
Cells(i, 39) = ExecuteExcel4Macro(Target41)
Cells(i, 40) = ExecuteExcel4Macro(Target42)
Cells(i, 41) = ExecuteExcel4Macro(Target43)
Application.EnableEvents = False 'エクセルマクロを動かさない
Windows(buf).Activate 'Dir コマンドで得たエクセルファイルを アクティブにして
Return
三ヶ月用:
Target44 = "'" & Path & "[" & buf & "]３ケ月用'!R1C18" 'ユーザー
Target45 = "'" & Path & "[" & buf & "]３ケ月用'!R3C18" '件名
Target46 = "'" & Path & "[" & buf & "]３ケ月用'!R5C18" 'オーダー
Target132 = "'" & Path & "[" & buf & "]３ケ月用'!R7C18" '売価
Target133 = "'" & Path & "[" & buf & "]３ケ月用'!R7C46" 'ＧＰ額
Target47 = "'" & Path & "[" & buf & "]３ケ月用'!R12C5"
Target48 = "'" & Path & "[" & buf & "]３ケ月用'!R12C6"
Target49 = "'" & Path & "[" & buf & "]３ケ月用'!R14C5"
Target50 = "'" & Path & "[" & buf & "]３ケ月用'!R14C6"
Target51 = "'" & Path & "[" & buf & "]３ケ月用'!R16C5"
Target52 = "'" & Path & "[" & buf & "]３ケ月用'!R16C6"
Target53 = "'" & Path & "[" & buf & "]３ケ月用'!R18C5"
Target54 = "'" & Path & "[" & buf & "]３ケ月用'!R18C6"
Target55 = "'" & Path & "[" & buf & "]３ケ月用'!R20C5"
Target56 = "'" & Path & "[" & buf & "]３ケ月用'!R20C6"
Target57 = "'" & Path & "[" & buf & "]３ケ月用'!R22C5"
Target58 = "'" & Path & "[" & buf & "]３ケ月用'!R22C6"
Target59 = "'" & Path & "[" & buf & "]３ケ月用'!R24C5"
Target60 = "'" & Path & "[" & buf & "]３ケ月用'!R24C6"
Target61 = "'" & Path & "[" & buf & "]３ケ月用'!R26C5"
Target62 = "'" & Path & "[" & buf & "]３ケ月用'!R26C6"
Target63 = "'" & Path & "[" & buf & "]３ケ月用'!R28C5"
Target64 = "'" & Path & "[" & buf & "]３ケ月用'!R28C6"
Target65 = "'" & Path & "[" & buf & "]３ケ月用'!R30C5"
Target66 = "'" & Path & "[" & buf & "]３ケ月用'!R30C6"
Target67 = "'" & Path & "[" & buf & "]３ケ月用'!R32C5"
Target68 = "'" & Path & "[" & buf & "]３ケ月用'!R32C6"
Target69 = "'" & Path & "[" & buf & "]３ケ月用'!R34C5"
Target70 = "'" & Path & "[" & buf & "]３ケ月用'!R34C6"
Target71 = "'" & Path & "[" & buf & "]３ケ月用'!R36C5"
Target72 = "'" & Path & "[" & buf & "]３ケ月用'!R36C6"
Target73 = "'" & Path & "[" & buf & "]３ケ月用'!R38C5"
Target74 = "'" & Path & "[" & buf & "]３ケ月用'!R38C6"
Target75 = "'" & Path & "[" & buf & "]３ケ月用'!R40C5"
Target76 = "'" & Path & "[" & buf & "]３ケ月用'!R40C6"
Target77 = "'" & Path & "[" & buf & "]３ケ月用'!R42C5"
Target78 = "'" & Path & "[" & buf & "]３ケ月用'!R42C6"
Target79 = "'" & Path & "[" & buf & "]３ケ月用'!R44C5"
Target80 = "'" & Path & "[" & buf & "]３ケ月用'!R44C6"
Target81 = "'" & Path & "[" & buf & "]３ケ月用'!R46C5"
Target82 = "'" & Path & "[" & buf & "]３ケ月用'!R46C6"
Target83 = "'" & Path & "[" & buf & "]３ケ月用'!R48C5"
Target84 = "'" & Path & "[" & buf & "]３ケ月用'!R48C6"
Target85 = "'" & Path & "[" & buf & "]３ケ月用'!R50C5"
Target86 = "'" & Path & "[" & buf & "]３ケ月用'!R50C6"
i = i + 3
If i > 71 Then
MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。"
Exit Sub
End If
Windows(win1).Activate
Cells(i, 1) = buf
Application.EnableEvents = True
Cells(i, 42) = ExecuteExcel4Macro(Target44)
Cells(i, 43) = ExecuteExcel4Macro(Target45)
Cells(i, 44) = ExecuteExcel4Macro(Target46)
Cells(i + 1, 44) = ExecuteExcel4Macro(Target132)
Cells(i + 2, 44) = ExecuteExcel4Macro(Target133)
Cells(i, 2) = ExecuteExcel4Macro(Target47)
Cells(i, 3) = ExecuteExcel4Macro(Target48)
Cells(i, 4) = ExecuteExcel4Macro(Target49)
Cells(i, 5) = ExecuteExcel4Macro(Target50)
Cells(i, 6) = ExecuteExcel4Macro(Target51)
Cells(i, 7) = ExecuteExcel4Macro(Target52)
Cells(i, 8) = ExecuteExcel4Macro(Target53)
Cells(i, 9) = ExecuteExcel4Macro(Target54)
Cells(i, 10) = ExecuteExcel4Macro(Target55)
Cells(i, 11) = ExecuteExcel4Macro(Target56)
Cells(i, 12) = ExecuteExcel4Macro(Target57)
Cells(i, 13) = ExecuteExcel4Macro(Target58)
Cells(i, 14) = ExecuteExcel4Macro(Target59)
Cells(i, 15) = ExecuteExcel4Macro(Target60)
Cells(i, 16) = ExecuteExcel4Macro(Target61)
Cells(i, 17) = ExecuteExcel4Macro(Target62)
Cells(i, 18) = ExecuteExcel4Macro(Target63)
Cells(i, 19) = ExecuteExcel4Macro(Target64)
Cells(i, 20) = ExecuteExcel4Macro(Target65)
Cells(i, 21) = ExecuteExcel4Macro(Target66)
Cells(i, 22) = ExecuteExcel4Macro(Target67)
Cells(i, 23) = ExecuteExcel4Macro(Target68)
Cells(i, 24) = ExecuteExcel4Macro(Target69)
Cells(i, 25) = ExecuteExcel4Macro(Target70)
Cells(i, 26) = ExecuteExcel4Macro(Target71)
Cells(i, 27) = ExecuteExcel4Macro(Target72)
Cells(i, 28) = ExecuteExcel4Macro(Target73)
Cells(i, 29) = ExecuteExcel4Macro(Target74)
Cells(i, 30) = ExecuteExcel4Macro(Target75)
Cells(i, 31) = ExecuteExcel4Macro(Target76)
Cells(i, 32) = ExecuteExcel4Macro(Target77)
Cells(i, 33) = ExecuteExcel4Macro(Target78)
Cells(i, 34) = ExecuteExcel4Macro(Target79)
Cells(i, 35) = ExecuteExcel4Macro(Target80)
Cells(i, 36) = ExecuteExcel4Macro(Target81)
Cells(i, 37) = ExecuteExcel4Macro(Target82)
Cells(i, 38) = ExecuteExcel4Macro(Target83)
Cells(i, 39) = ExecuteExcel4Macro(Target84)
Cells(i, 40) = ExecuteExcel4Macro(Target85)
Cells(i, 41) = ExecuteExcel4Macro(Target86)
Application.EnableEvents = False
Windows(buf).Activate
Return
四ヶ月用:
Target87 = "'" & Path & "[" & buf & "]４ケ月用'!R1C23" 'ユーザー
Target88 = "'" & Path & "[" & buf & "]４ケ月用'!R3C23" '件名
Target89 = "'" & Path & "[" & buf & "]４ケ月用'!R5C23" 'オーダー
Target134 = "'" & Path & "[" & buf & "]４ケ月用'!R7C23" '売価
Target135 = "'" & Path & "[" & buf & "]４ケ月用'!R7C59" 'ＧＰ額
Target90 = "'" & Path & "[" & buf & "]４ケ月用'!R12C5"
Target91 = "'" & Path & "[" & buf & "]４ケ月用'!R12C6"
Target92 = "'" & Path & "[" & buf & "]４ケ月用'!R14C5"
Target93 = "'" & Path & "[" & buf & "]４ケ月用'!R14C6"
Target94 = "'" & Path & "[" & buf & "]４ケ月用'!R16C5"
Target95 = "'" & Path & "[" & buf & "]４ケ月用'!R16C6"
Target96 = "'" & Path & "[" & buf & "]４ケ月用'!R18C5"
Target97 = "'" & Path & "[" & buf & "]４ケ月用'!R18C6"
Target98 = "'" & Path & "[" & buf & "]４ケ月用'!R20C5"
Target99 = "'" & Path & "[" & buf & "]４ケ月用'!R20C6"
Target100 = "'" & Path & "[" & buf & "]４ケ月用'!R22C5"
Target101 = "'" & Path & "[" & buf & "]４ケ月用'!R22C6"
Target102 = "'" & Path & "[" & buf & "]４ケ月用'!R24C5"
Target103 = "'" & Path & "[" & buf & "]４ケ月用'!R24C6"
Target104 = "'" & Path & "[" & buf & "]４ケ月用'!R26C5"
Target105 = "'" & Path & "[" & buf & "]４ケ月用'!R26C6"
Target106 = "'" & Path & "[" & buf & "]４ケ月用'!R28C5"
Target107 = "'" & Path & "[" & buf & "]４ケ月用'!R28C6"
Target108 = "'" & Path & "[" & buf & "]４ケ月用'!R30C5"
Target109 = "'" & Path & "[" & buf & "]４ケ月用'!R30C6"
Target110 = "'" & Path & "[" & buf & "]４ケ月用'!R32C5"
Target111 = "'" & Path & "[" & buf & "]４ケ月用'!R32C6"
Target112 = "'" & Path & "[" & buf & "]４ケ月用'!R34C5"
Target113 = "'" & Path & "[" & buf & "]４ケ月用'!R34C6"
Target114 = "'" & Path & "[" & buf & "]４ケ月用'!R36C5"
Target115 = "'" & Path & "[" & buf & "]４ケ月用'!R36C6"
Target116 = "'" & Path & "[" & buf & "]４ケ月用'!R38C5"
Target117 = "'" & Path & "[" & buf & "]４ケ月用'!R38C6"
Target118 = "'" & Path & "[" & buf & "]４ケ月用'!R40C5"
Target119 = "'" & Path & "[" & buf & "]４ケ月用'!R40C6"
Target120 = "'" & Path & "[" & buf & "]４ケ月用'!R42C5"
Target121 = "'" & Path & "[" & buf & "]４ケ月用'!R42C6"
Target122 = "'" & Path & "[" & buf & "]４ケ月用'!R44C5"
Target123 = "'" & Path & "[" & buf & "]４ケ月用'!R44C6"
Target124 = "'" & Path & "[" & buf & "]４ケ月用'!R46C5"
Target125 = "'" & Path & "[" & buf & "]４ケ月用'!R46C6"
Target126 = "'" & Path & "[" & buf & "]４ケ月用'!R48C5"
Target127 = "'" & Path & "[" & buf & "]４ケ月用'!R48C6"
Target128 = "'" & Path & "[" & buf & "]４ケ月用'!R50C5"
Target129 = "'" & Path & "[" & buf & "]４ケ月用'!R50C6"
i = i + 3
If i > 71 Then
MsgBox "日程表に空きがなく転記しきれません。管理表を減らして下さい。"
Exit Sub
End If
Windows(win1).Activate
Cells(i, 1) = buf
Application.EnableEvents = True
Cells(i, 42) = ExecuteExcel4Macro(Target87)
Cells(i, 43) = ExecuteExcel4Macro(Target88)
Cells(i, 44) = ExecuteExcel4Macro(Target89)
Cells(i + 1, 44) = ExecuteExcel4Macro(Target134)
Cells(i + 2, 44) = ExecuteExcel4Macro(Target135)
Cells(i, 2) = ExecuteExcel4Macro(Target90)
Cells(i, 3) = ExecuteExcel4Macro(Target91)
Cells(i, 4) = ExecuteExcel4Macro(Target92)
Cells(i, 5) = ExecuteExcel4Macro(Target93)
Cells(i, 6) = ExecuteExcel4Macro(Target94)
Cells(i, 7) = ExecuteExcel4Macro(Target95)
Cells(i, 8) = ExecuteExcel4Macro(Target96)
Cells(i, 9) = ExecuteExcel4Macro(Target97)
Cells(i, 10) = ExecuteExcel4Macro(Target98)
Cells(i, 11) = ExecuteExcel4Macro(Target99)
Cells(i, 12) = ExecuteExcel4Macro(Target100)
Cells(i, 13) = ExecuteExcel4Macro(Target101)
Cells(i, 14) = ExecuteExcel4Macro(Target102)
Cells(i, 15) = ExecuteExcel4Macro(Target103)
Cells(i, 16) = ExecuteExcel4Macro(Target104)
Cells(i, 17) = ExecuteExcel4Macro(Target105)
Cells(i, 18) = ExecuteExcel4Macro(Target106)
Cells(i, 19) = ExecuteExcel4Macro(Target107)
Cells(i, 20) = ExecuteExcel4Macro(Target108)
Cells(i, 21) = ExecuteExcel4Macro(Target109)
Cells(i, 22) = ExecuteExcel4Macro(Target110)
Cells(i, 23) = ExecuteExcel4Macro(Target111)
Cells(i, 24) = ExecuteExcel4Macro(Target112)
Cells(i, 25) = ExecuteExcel4Macro(Target113)
Cells(i, 26) = ExecuteExcel4Macro(Target114)
Cells(i, 27) = ExecuteExcel4Macro(Target115)
Cells(i, 28) = ExecuteExcel4Macro(Target116)
Cells(i, 29) = ExecuteExcel4Macro(Target117)
Cells(i, 30) = ExecuteExcel4Macro(Target118)
Cells(i, 31) = ExecuteExcel4Macro(Target119)
Cells(i, 32) = ExecuteExcel4Macro(Target120)
Cells(i, 33) = ExecuteExcel4Macro(Target121)
Cells(i, 34) = ExecuteExcel4Macro(Target122)
Cells(i, 35) = ExecuteExcel4Macro(Target123)
Cells(i, 36) = ExecuteExcel4Macro(Target124)
Cells(i, 37) = ExecuteExcel4Macro(Target125)
Cells(i, 38) = ExecuteExcel4Macro(Target126)
Cells(i, 39) = ExecuteExcel4Macro(Target127)
Cells(i, 40) = ExecuteExcel4Macro(Target128)
Cells(i, 41) = ExecuteExcel4Macro(Target129)
Application.EnableEvents = False
Windows(buf).Activate
Return
End Sub
（ふみ） 2013/12/13(金) 09:22
ExecuteExcel4Macroを使っているのに、ブックを開く意味がない。 41行分は同じなので、配列にまとめ、最初の4行分だけ別個に。 実際のデータが不明で、動かしていないので、ブックをコピーしてから実行することを推奨。 不備が見つかったので掲載削除1321
（稲葉） 2013/12/13(金) 13:17
ブックを開くしか能がなかったのは私です。すみません。m(__)m
ふみさん
稲葉さんの 2013/12/12(木) 17:55 のプログラムを入れたときに、最後の End Sub をそのまま入れられたのではないでしょうか？
そこは、Exit Sub に変えて、その後に
二ヶ月用：
以下をを続けないと．．．．
フォルダー内のファイルを並べるのは無理ですので、出てきたリストを並べませんか？
稲葉さんのなら、並んだ結果になると思いますし、
今出ている分でも、ホーム の 一番右側 編集の 「並べ替えとフィルター」を使って
並べ直せば、お望みのものが出てくると思います。
ためにし、並んでいないシートをコピー（バックアップ）して、並べたい範囲を選択し、
ユーザー設定の並べ替えを選んで、ファイル名の列を選んで並べれば、ご希望のものが
できあがると思います。
（パオ〜〜ン） 2013/12/13(金) 13:27
再掲載
ワークブックは開きます。（ForEachの関係）
あといろいろ手直ししました。
Sub ふみ()
Dim j As Long
Dim buf As String 'ファイル名
Dim myPath As String
Dim sht As Variant
Dim FN As Variant
Dim r As Long
myPath = "W:\ふみ\社内（原価・日程）管理表\"
r = 9
With CreateObject("System.Collections.ArrayList")
.Add Dir(myPath & "*.xlsm")
Do
.Add Dir()
Loop Until .Item(.Count - 1) = ""
.Sort
.removeat 0
Set FN = .Clone
End With
MsgBox "ファイル数は" & FN.Count & "です。"
Application.EnableEvents = False
For j = 1 To FN.Count
If Len(Replace("B1B3B9C8", Left(FN(j), 2), "")) < 8 Then
Workbooks.Open myPath & FN(j), ReadOnly:=True
If FN(j) <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
For Each sht In Workbooks(FN(j)).Worksheets 'そのワークシートについて
Call SELECT_MONTH(sht.Name, myPath, FN(j))
Next sht
End If
Workbooks(FN(j)).Close SaveChanges:=False
End If
If r > 71 Then MsgBox ("日程表に空きがなく転記しきれません。管理表を減らして下さい。"): Exit Sub
Next
Application.EnableEvents = True
Exit Sub
'以下サブルーチン
End Sub
Private Sub SELECT_MONTH(ByVal MON As String, ByVal myPath As String, ByVal myFile As String, ByRef r As Long)
Dim tbl As Variant
Dim i As Long
myPath = "'" & myPath & "[" & buf & "]" & MON & "'!"
tbl = COL(MON)
ThisWorkbook.Activate
With ActiveSheet
.Cells(r, 42) = tmp(101)
.Cells(r, 43) = tmp(102)
.Cells(r, 44) = tmp(103)
.Cells(r + 1, 44) = tmp(104)
.Cells(r + 2, 44) = tmp(105)
For i = 2 To 41
.Cells(r, i) = ExecuteExcel4Macro(myPath & tbl(i))
Next i
End With
r = r + 3
End Sub
Private Function COL(ByVal MON As String) As Variant
Dim tmp(150) As Variant
tmp(2) = "R12C5"
tmp(3) = "R12C6"
tmp(4) = "R14C5"
tmp(5) = "R14C6"
tmp(6) = "R16C5"
tmp(7) = "R16C6"
tmp(8) = "R18C5"
tmp(9) = "R18C6"
tmp(10) = "R20C5"
tmp(11) = "R20C6"
tmp(12) = "R22C5"
tmp(13) = "R22C6"
tmp(14) = "R24C5"
tmp(15) = "R24C6"
tmp(16) = "R26C5"
tmp(17) = "R26C6"
tmp(18) = "R28C5"
tmp(19) = "R28C6"
tmp(20) = "R30C5"
tmp(21) = "R30C6"
tmp(22) = "R32C5"
tmp(23) = "R32C6"
tmp(24) = "R34C5"
tmp(25) = "R34C6"
tmp(26) = "R36C5"
tmp(27) = "R36C6"
tmp(28) = "R38C5"
tmp(29) = "R38C6"
tmp(30) = "R40C5"
tmp(31) = "R40C6"
tmp(32) = "R42C5"
tmp(33) = "R42C6"
tmp(34) = "R44C5"
tmp(35) = "R44C6"
tmp(36) = "R46C5"
tmp(37) = "R46C6"
tmp(38) = "R48C5"
tmp(39) = "R48C6"
tmp(40) = "R50C5"
tmp(41) = "R50C6"
Select Case MON
Case "２ケ月用"
tmp(101) = "R1C17"
tmp(102) = "R3C17"
tmp(103) = "R5C17"
tmp(104) = "R7C17"
tmp(105) = "R7C38"
Case "３ケ月用"
tmp(101) = "R1C18"
tmp(102) = "R3C18"
tmp(103) = "R5C18"
tmp(104) = "R7C18"
tmp(105) = "R7C46"
Case "４ケ月用"
tmp(101) = "R1C23"
tmp(102) = "R3C23"
tmp(103) = "R5C23"
tmp(104) = "R7C23"
tmp(105) = "R7C59"
End Select
COL = tmp
End Function
（稲葉） 2013/12/13(金) 13:29
稲葉さん
実行してみましたが、Call SELECT_MONTHのサブルーチンを呼び出すところで、
コンパイルエラーで「引数は省略できません」と出ます。
（ふみ） 2013/12/13(金) 14:17
すみません、付けたし忘れました。
（稲葉） 2013/12/13(金) 15:29
（ふみ） 2013/12/13(金) 15:46
テストしないとだめですね。
データがほしい
myPath = "'" & myPath & "[" & myFile & "]" & MON & "'!"
（稲葉） 2013/12/13(金) 15:51
ごめんなさい、金曜日にコメント書いたのですが、なぜか掲載されていませんでした。
myPath = "'" & myPath & "[" & myFile & "]" & MON & "'!"
に変更したら、tmpのところで、「SubまたはFunctionが定義されていません」と
なりました。
テストする為のデータはどのようなものでしょうか？
（ふみ） 2013/12/16(月) 11:29
めんどくさがらずにテストすれば一発だった！
ごめんなさいね。
全部差し替えです。
Sub ふみ()
Dim j As Long
Dim buf As String 'ファイル名
Dim myPath As String
Dim sht As Variant
Dim FN As Variant
Dim r As Long
myPath = "W:\ふみ\社内（原価・日程）管理表\"
r = 9
With CreateObject("System.Collections.ArrayList")
.Add Dir(myPath & "*.xlsm")
Do
.Add Dir()
Loop Until .Item(.Count - 1) = ""
.Sort
.removeat 0
Set FN = .Clone
End With
MsgBox "ファイル数は" & FN.Count & "です。"
Application.EnableEvents = False
For j = 0 To FN.Count - 1
If Len(Replace("B1B3B9C8", Left(FN(j), 2), "")) < 8 Then
Workbooks.Open myPath & FN(j), ReadOnly:=True
If FN(j) <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
For Each sht In Workbooks(FN(j)).Worksheets 'そのワークシートについて
Call SELECT_MONTH(sht.Name, myPath, FN(j), r)
Next sht
End If
Workbooks(FN(j)).Close SaveChanges:=False
End If
If r > 71 Then MsgBox ("日程表に空きがなく転記しきれません。管理表を減らして下さい。"): Exit Sub
Next
Application.EnableEvents = True
Exit Sub
End Sub
Private Sub SELECT_MONTH(ByVal MON As String, ByVal myPath As String, ByVal myFile As String, ByRef r As Long)
Dim tbl As Variant
Dim i As Long
myPath = "'" & myPath & "[" & myFile & "]" & MON & "'!"
tbl = COL(MON)
ThisWorkbook.Activate
With ActiveSheet
.Cells(r, 42) = ExecuteExcel4Macro(myPath & tbl(101))
.Cells(r, 43) = ExecuteExcel4Macro(myPath & tbl(102))
.Cells(r, 44) = ExecuteExcel4Macro(myPath & tbl(103))
.Cells(r + 1, 44) = ExecuteExcel4Macro(myPath & tbl(104))
.Cells(r + 2, 44) = ExecuteExcel4Macro(myPath & tbl(105))
For i = 2 To 41
.Cells(r, i) = ExecuteExcel4Macro(myPath & tbl(i))
Next i
End With r = r + 3
End Sub
Private Function COL(ByVal MON As String) As Variant
Dim tmp(150) As Variant
tmp(2) = "R12C5"
tmp(3) = "R12C6"
tmp(4) = "R14C5"
tmp(5) = "R14C6"
tmp(6) = "R16C5"
tmp(7) = "R16C6"
tmp(8) = "R18C5"
tmp(9) = "R18C6"
tmp(10) = "R20C5"
tmp(11) = "R20C6"
tmp(12) = "R22C5"
tmp(13) = "R22C6"
tmp(14) = "R24C5"
tmp(15) = "R24C6"
tmp(16) = "R26C5"
tmp(17) = "R26C6"
tmp(18) = "R28C5"
tmp(19) = "R28C6"
tmp(20) = "R30C5"
tmp(21) = "R30C6"
tmp(22) = "R32C5"
tmp(23) = "R32C6"
tmp(24) = "R34C5"
tmp(25) = "R34C6"
tmp(26) = "R36C5"
tmp(27) = "R36C6"
tmp(28) = "R38C5"
tmp(29) = "R38C6"
tmp(30) = "R40C5"
tmp(31) = "R40C6"
tmp(32) = "R42C5"
tmp(33) = "R42C6"
tmp(34) = "R44C5"
tmp(35) = "R44C6"
tmp(36) = "R46C5"
tmp(37) = "R46C6"
tmp(38) = "R48C5"
tmp(39) = "R48C6"
tmp(40) = "R50C5"
tmp(41) = "R50C6"
Select Case MON
Case "２ケ月用"
tmp(101) = "R1C17"
tmp(102) = "R3C17"
tmp(103) = "R5C17"
tmp(104) = "R7C17"
tmp(105) = "R7C38"
Case "３ケ月用"
tmp(101) = "R1C18"
tmp(102) = "R3C18"
tmp(103) = "R5C18"
tmp(104) = "R7C18"
tmp(105) = "R7C46"
Case "４ケ月用"
tmp(101) = "R1C23"
tmp(102) = "R3C23"
tmp(103) = "R5C23"
tmp(104) = "R7C23"
tmp(105) = "R7C59"
End Select
COL = tmp
End Function
（稲葉） 2013/12/16(月) 11:57
コードを走らせてみましたが、最初は読みにいくファイルのシート保護で
ひっかかったのですが、１つ目のファイルのロックを全て解除したところ、
なぜか全てのファイルを開く様になりました。
あと、開始の行が９＋３で１２からなのでｒ＝１２に変更しました。
最大の問題はデータは転送するのですが、矢印を描写しなくなりました。
どこかにApplication.EnableEvents = Trueを追加すれば良いのでしょうか？
（ふみ） 2013/12/16(月) 13:47
ファイル名も転記させたかったので、.Cells(r, 1) = bufと
ByVal buf As Stringを追記して
Call SELECT_MONTH(sht.Name, myPath, FN(j), r, buf)としたのですが
転記しません。
.Cells(r, 1) = bufではダメなのでしょうか？
（ふみ） 2013/12/16(月) 14:21
For i = 2 To 41
.Cells(r, i) = ExecuteExcel4Macro(myPath & tbl(i))を
For i = 1 To 41にしたらエラーになりました。
（ふみ） 2013/12/16(月) 14:28
イミディエイトウィンドウでtbl(1)の値を確認してください。
Emptyはセルに入れられないのでエラーになります。
本題。
どうせ開いているなら、そのまま引っ張った方が早いので、ExecuteExcel4Macroをやめて
書き換えました。
R1C1は個人的に分かりにくいのでA1に。
開くときだけイベント抑止して、転記するときにイベントが発生するように変更。
ファイル名はFN(j)で引っ張っているので、SELECT_MONTH内で入れるようにしました。
SELECT_MONTHで引数にパスは必要ないので、削りました。
Sub ふみ20131216()
Dim j As Long
Dim buf As String 'ファイル名
Dim myPath As String
Dim sht As Variant
Dim FN As Variant
Dim r As Long
myPath = "C:\エクセルの学校\ふみ\"
r = 12
With CreateObject("System.Collections.ArrayList")
.Add Dir(myPath & "*.xlsm")
Do
.Add Dir()
Loop Until .Item(.Count - 1) = ""
.Sort
.removeat 0
Set FN = .Clone
End With
MsgBox "ファイル数は" & FN.Count - 1 & "です。"
For j = 0 To FN.Count - 1
If Len(Replace("B1B3B9C8", Left(FN(j), 2), "")) < 8 Then
Application.EnableEvents = False
Workbooks.Open myPath & FN(j), ReadOnly:=True
Application.EnableEvents = True
If FN(j) <> ThisWorkbook.Name Then '当該エクセルファイルが、このファイルでないとき、以下を処理
For Each sht In Workbooks(FN(j)).Worksheets 'そのワークシートについて
Call SELECT_MONTH(sht.Name, FN(j), r)
Next sht
End If
Workbooks(FN(j)).Close SaveChanges:=False
End If
If r > 71 Then MsgBox ("日程表に空きがなく転記しきれません。管理表を減らして下さい。"): Exit Sub
Next
Exit Sub
End Sub
Private Sub SELECT_MONTH(ByVal MON As String, ByVal myFile As String, ByRef r As Long)
Dim tbl As Variant
Dim i As Long
Dim sh As Worksheet
Set sh = Workbooks(myFile).Sheets(MON)
tbl = COL(MON)
ThisWorkbook.Activate
With ActiveSheet
.Cells(r + 0, 1) = myFile
.Cells(r + 0, 42) = sh.Range(tbl(101))
.Cells(r + 0, 43) = sh.Range(tbl(102))
.Cells(r + 0, 44) = sh.Range(tbl(103))
.Cells(r + 1, 44) = sh.Range(tbl(104))
.Cells(r + 2, 44) = sh.Range(tbl(105))
For i = 2 To 41
.Cells(r, i) = sh.Range(tbl(i))
Next i
End With
r = r + 3
End Sub
Private Function COL(ByVal MON As String) As Variant
Dim tmp(150) As Variant
tmp(2) = "E12"
tmp(3) = "F12"
tmp(4) = "E14"
tmp(5) = "F14"
tmp(6) = "E16"
tmp(7) = "F16"
tmp(8) = "E18"
tmp(9) = "F18"
tmp(10) = "E20"
tmp(11) = "F20"
tmp(12) = "E22"
tmp(13) = "F22"
tmp(14) = "E24"
tmp(15) = "F24"
tmp(16) = "E26"
tmp(17) = "F26"
tmp(18) = "E28"
tmp(19) = "F28"
tmp(20) = "E30"
tmp(21) = "F30"
tmp(22) = "E32"
tmp(23) = "F32"
tmp(24) = "E34"
tmp(25) = "F34"
tmp(26) = "E36"
tmp(27) = "F36"
tmp(28) = "E38"
tmp(29) = "F38"
tmp(30) = "E40"
tmp(31) = "F40"
tmp(32) = "E42"
tmp(33) = "F42"
tmp(34) = "E44"
tmp(35) = "F44"
tmp(36) = "E46"
tmp(37) = "F46"
tmp(38) = "E48"
tmp(39) = "F48"
tmp(40) = "E50"
tmp(41) = "F50"
Select Case MON
Case "２ケ月用"
tmp(101) = "Q1"
tmp(102) = "Q3"
tmp(103) = "Q5"
tmp(104) = "Q7"
tmp(105) = "AL7"
Case "３ケ月用"
tmp(101) = "R1"
tmp(102) = "R3"
tmp(103) = "R5"
tmp(104) = "R7"
tmp(105) = "AT7"
Case "４ケ月用"
tmp(101) = "W1"
tmp(102) = "W3"
tmp(103) = "W5"
tmp(104) = "W7"
tmp(105) = "BG7"
End Select
COL = tmp
End Function
（稲葉） 2013/12/16(月) 14:51
また稲葉さんに全て頼りっきりになってしまいました。
自分でアレンジ出来る様に、頂いたコードを
出来る限り理解するつもりです。
ありがとう御座いました。
（ふみ） 2013/12/16(月) 15:32
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.