こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

複数シートをブックにするマクロを応用して。。

1ブック内にyymmdd(日付)シートが多数あり、それを月別yymmごとブックを作成するマクロです。
これは以前、回答して頂いた「n-jun」さんの構文です(n-junさん、重宝しています、感謝!)
Private Sub CommandButton1_Click()
Dim myDic As Object
Dim wb1 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim sh As Worksheet
Dim myKey
Set myDic = CreateObject("Scripting.Dictionary")
Set wb1 = ThisWorkbook
Application.ScreenUpdating = False

For Each sh In wb1.Worksheets
myDic(Left(sh.Name, 4) & "_") = Empty
Next

For Each myKey In myDic.keys
For Each sh In wb1.Worksheets
If InStr(sh.Name, Left(myKey, 4)) > 0 Then

If wb Is Nothing Then
wb1.Worksheets(sh.Name).Copy
Set wb = ActiveWorkbook
Else
wb1.Worksheets(sh.Name).Copy after:=wb.Sheets(wb.Sheets.Count)
End If
End If
Next

Application.DisplayAlerts = False
wb.SaveAs Filename:="C:\仕事\月別" & "\" & Left(myKey, 4) & ".xls"
wb.Close
Set wb = Nothing
Application.DisplayAlerts = True
Next

Application.ScreenUpdating = True
Set myDic = Nothing
Worksheets("main").Activate
MsgBox "出力完了"
End Sub

実は、これをフォルダ内のブックの場合は?
として応用ができないか悩んでいます。
つまり、フォルダ内にyymmddブックが多数あり、
これを月別yymmとして、それぞれまとめたいのです。
Set wb1 = ThisWorkbookの箇所が、
フォルダ内のブック指定になると思うのですが、
下記コードでどうなんでしょうか?動きません。

myfdr = "C:\仕事\月別"
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
Set wb1 = Workbooks.Open(myfdr & "\" & fname)
変更箇所、アドバイス頂ければ助かります。お願いします

投稿日時 - 2009-03-10 23:13:49

QNo.4786094

困ってます

質問者が選んだベストアンサー

ご迷惑おかけしています
#1の補足の読みました
>試したところ、該当ファイルがフォルダから全部消えてしまい
すいません、BOOKを消す処理はしていませんが
BOOKの移動処理をする際に、移動先のフォルダの指定が間違っていました
X Name MyPath & MyName As MyDire & MyName
○ Name MyPath & MyName As MyPath & MyDire & MyName
間違ったBOOKの移動先ですが、新規作成したBOOKを初めて保存する時の
フォルダにフォルダが作成されていると思います、ご確認ください

>あらためて、下記構文まねて作ってみたのですが
処理の対象が違うため、殆んど使用できるところがありません
ただ、エラーの原因は
Do
For i・・・
For ii・・・

Next ii
Next i
Loop
としなければならないところ(繰り返し処理を開始した順番の逆順で処理を終了させる)
Do
For i・・・
For ii・・・

Next ii
Loop
Next i
となっているため

確認ですが、C:\仕事\月別フォルダにある、複数のyymmdd.xlsを
yymmフォルダをC:\仕事\月別に作成し、対象のyymmdd.xlsを移動する
C:\仕事\月別にあるのは、各yymmフォルダのみでyymmdd.xlsはすべて
対象のフォルダへ移動でよろしいですか
ならば#1のマクロです

さらに、移動先に同名ファイルがあった場合の処理を加えたのが、#2です

投稿日時 - 2009-03-14 23:30:16

お礼

hige_082さん、遅くなりました。
頂いたアドバイスの構文もとに、なんとか理想の処理に近づきました。助かりました。hige_082さん、ブックマークです^^v

投稿日時 - 2009-03-25 17:38:19

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

同名ファイルが存在する場合の処理を追加しました

Sub test()
Dim MyPath, MyName, MyDire, MyYesNo
MyPath = "C:\仕事\月別\"
Do
MyName = Dir(MyPath & "*.xls", vbNormal)
If MyName = "" Then Exit Sub
MyDire = Left(MyName, 4) & "\"
If Dir(MyDire, vbDirectory) = "" Then MkDir MyDire
If MyName = Dir(MyDire & MyName, vbNormal) Then
MyYesNo = MsgBox("同名のファイルが存在します" & vbCrLf & "上書きしますか?", vbOKCancel, "同名ファイルの処理")
Else
MyYesNo = 0
End If
Select Case MyYesNo
Case 0
Name MyPath & MyName As MyPath & MyDire & MyName
Case 1
Kill MyPath & MyDire & MyName
Name MyPath & MyName As MyPath & MyDire & MyName
Case 2
Kill MyPath & MyName
End Select
Loop
End Sub

上書きしない場合は、親フォルダのファイルは消す様にしています

投稿日時 - 2009-03-11 01:43:48

ANo.1

こんな感じで

Sub test()
Dim MyPath, MyName, MyDire
MyPath = "C:\仕事\月別\"
Do
MyName = Dir(MyPath & "*.xls", vbNormal)
If MyName = "" Then Exit Sub
MyDire = Left(MyName, 4) & "\"
If Dir(MyDire, vbDirectory) = "" Then MkDir MyDire
Name MyPath & MyName As MyDire & MyName
Loop
End Sub

バックアップを取って、試してから使用してね

投稿日時 - 2009-03-11 00:58:29

補足

hige_082さん、ありがとうございます。
試したところ、該当ファイルがフォルダから全部消えてしまい、
その後、ウンともスンとも変化無しです。。。 
指定パスにも作成されていませんでした。
原因、まったくわからずです。すみません。

あらためて、下記構文まねて作ってみたのですが、
Loopに対するDoが見当たりませんとエラーです。
「Do」はあるのですが、何でエラーしてるのでしょうか?
ビギナーここまです (TT)助けてください

Private Sub CommandButton1_Click()
Dim myDic As Object
Dim wb1 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim sh As Worksheet
Dim myKey
Dim MyPath, MyName, MyDire

Set myDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
MyPath = "C:\お仕事\年月日"
Do
Set wb1 = Workbooks.Open(Filename:=MyPath & "\" & "*.xls")
If wb1 = "" Then Exit Sub

For Each sh In wb1.Worksheets
myDic(Left(sh.Name, 4) & "_") = Empty
Next

For Each myKey In myDic.keys
For Each sh In wb1.Worksheets
If InStr(sh.Name, Left(myKey, 4)) > 0 Then

If wb Is Nothing Then
wb1.Worksheets(sh.Name).Copy
Set wb = ActiveWorkbook
Else
wb1.Worksheets(sh.Name).Copy after:=wb.Sheets(wb.Sheets.Count)
End If
End If
Next

Application.DisplayAlerts = False
wb.SaveAs Filename:="C:\お仕事\年月別" & "\" & Left(myKey, 4) & ".xls"
wb.Close
Loop
Set wb = Nothing
Application.DisplayAlerts = True
Next

Application.ScreenUpdating = True
Set myDic = Nothing
Worksheets("main").Activate
MsgBox "出力完了"

End Sub

投稿日時 - 2009-03-14 14:32:19

あなたにオススメの質問