ワークシートを移動するＶＢＡをご指導ください。

質問

現在、下記状態でワークシートの移動を手動で行っています。

このように作成した実績ワークシートの五つ目を、移動ボタンをクリックした時、
実績フォルダーの年度別フォルダーの月別Ｂｏｏｋに、
１月から昇順に移動したいと考えております。

その方法、手順等をご指導お願い申し上げます。

尚、移動するとき移動先のＢｏｏｋを開かなければならないのら、その方法もお願い申し上げます。

(1)　実績作成フォルダー
　　　(2)　実績作成Ｂｏｏｋ
　　　　　　(3)　実績ワークシート　→　　ワークシート名は日付です（例　11-11-20）

(1)　実績フォルダー（移動先）
　　　(2)　年度別フォルダー　（例　2011年度）
　　　　　　(3)　月別Ｂｏｏｋ　　（例　11-11）
　　　　　　　　　(4)　実績ワークシート　（例　11-11-20）
　　　　　　(3)　月別Ｂｏｏｋ（例　11-12）
　　　　　　　　　(4)　実績ワークシート　（例　11-12-01）

　　　(2)　年度別フォルダー　（例　2012年度）
　　　　　　(3)　月別Ｂｏｏｋ　　（例　12-01）
　　　　　　　　　実績ワークシート　（例　12-01-05）
　　　　　　(3)　月別Ｂｏｏｋ　　（例　12-02）
　　　　　　　　　実績ワークシート　（例　12-02-01）

回答No.1

keithin · ベストアンサー

５枚目のシート，その１枚だけを，目的のブックの所定の場所に差し込みたいという事ですね。
ぶっちゃけ指導するのはメンドクサイので，コタエを書いておきます。自習して，必要な部分は自力で応用してください。

＃追加機能
　・５枚目のシート名が不適切だった場合の対応
　・所定のフォルダが無かった場合の対応
　・所定のブックが無かった場合の対応

sub macro1()
　dim y,m,d
　dim myPath as string
　dim w as workbook
　dim i as long
’準備
　d = thisworkbook.worksheets(5).name

　if not d like "??-??-??" then
　　msgbox "INVALID SHEET NAME"
　　exit sub
　end if

　mypath = "c:\どこかのフォルダ\実績フォルダー\"　　’★適切に設定
　y = year(datevalue(d)) & "年度\"
　m = format(datevalue(d), "yy-mm") & ".xls"　　’★または".xlsx"

’ブックを開く
　on error resume next
　mkdir mypath & y
　on error goto errhandle
　set w = workbooks.open(filename:=mypath & y & m)
　on error goto 0

’差込先を探して差し込む
　for i = 1 to w.worksheets.count
　　if w.worksheets(i).name > d then exit for
　next i
　if i = 1 then
　　thisworkbook.worksheets(5).copy before:=w.worksheets(1)
　else
　　thisworkbook.worksheets(5).copy after:=w.worksheets(i - 1)
　end if

retpos:
’「５枚目のシートを移動したい」場合は次を生かす
'application.displayalerts = false
'thisworkbook.worksheets(5).delete
'application.displayalerts = true

’終了する
　w.close savechanges:=true
　exit sub

’実績ブックが用意されてなかったら作らないといけない
errhandle:
　thisworkbook.worksheets(5).copy
　set w = activeworkbook
　w.saveas filename:=mypath & y & m
　resume retpos

end sub

お礼

keithin先生

質問の拙い表現にもかかわらず、ご推察いただき完璧なご指導を賜り心より御礼申し上げます。

随所に適切なコメントを付記していただいたり、拡張子までご配慮いただきありがとうございました。

お蔭様でこのように出来れば最高と考えていました通り出来ました。