新しく開いたブックをアクティブにするマクロ

Question

マクロ 新しく作ったブックをアクティブにする

マクロ初心者です。

マクロを使って同階層にあるファイルのアクティブのシートを
ひとつのブックにコピーして保存するマクロを作りたいと思ってます。
他の質問を参照して下記のコードを途中まで作成しました。

参照した質問では、
マクロの入っているブックにシートをコピーするようでしたが、
そうすると保存した時にマクロも保存されてしまうので
私なりに調べて、新しいブックにシートコピーするようにしましたが、
この記述の後、新しいブックをアクティブにする記述がわからず、
保存できなくなってしまいました。

ここまで終わるとマクロの入っているブックがアクティブになって終わります。
このあと新しく開いたブックをアクティブにして、
ブックのsheet1～3を削除して、名前をつけて保存したいのですが
開いたブックをアクティブにするマクロをご伝授ください。

あたらしくブックをつくるとbook1～・・・と名前が変わってしまうので
変数で名づけたいのですが、やり方が良くわかりませんのでよろしくお願いします。

何卒よろしくお願いします。


Sub consolid_test()

Dim shCnt As Integer
Dim Wb As Workbook
Dim i As Integer
Dim sh As Worksheet
Dim nSh As Worksheet
Dim fName As String
Dim ka As String

Application.ScreenUpdating = False '画面更新を一時停止

Application.DisplayAlerts = False

Set mb = Workbooks.Add '新しいコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fName = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fName = Empty '全て検索
If fName <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set Wb = Workbooks.Open(myfdr & "\" & fName) 'そのブックを開きwbとする。

Wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く

ActiveSheet.Name = Range("B16") 'シート名の変更

ActiveSheet.Unprotect 'シート全体をコピーして値にする
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Wb.Close (False) '保存の有無を聞かずに保存しないで閉じる
N = N + 1 'ブック数をカウント
End If
fName = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す

・
・
・
・

KenKen_SP · Accepted Answer

こんにちは。こんな感じにすれば不要なブランクシートはできません。シート名を変更する際の簡単なエラートラップはついで。余談になりますけど、 > If fName <> mb.Name Then は ThisWorkbook と比較した方が良いでしょう。そして統合したブックの保存の際に同名ファイル確認して Save するか、保存作業はユーザーに任せた方が良いと思います。ご参考までに。余談その２　　　　Active にできないのは、Application.ScreenUpdating = False のせい　　な予感。 Sub sample() 　　Dim wbSrc　　　 As Workbook 　　Dim wbDst　　　 As Workbook 　　Dim sFolderPath As String 　　Dim sFileName　 As String 　　Dim sFilePath　 As String 　　Dim fCopied　　 As Boolean 　　　　Application.ScreenUpdating = False 　　Application.DisplayAlerts = False 　　　　sFolderPath = ThisWorkbook.Path 　　　　sFileName = Dir$(sFolderPath & "\*.xls") 　　　　fCopied = False 　　Do While Len(sFileName) > 0 　　　　　　　　sFilePath = sFolderPath & "\" & sFileName 　　　　' // マクロのあるブック以外とする　　　　If sFilePath <> ThisWorkbook.FullName Then 　　　　　　　　　　　　' // ソースブックを開く　　　　　　Set wbSrc = Workbooks.Open(sFilePath) 　　　　　　　　　　　　' // 進捗表示　　　　　　Application.StatusBar = "Copy ... " & sFileName 　　　　　　DoEvents 　　　　　　　　　　　　' // シートのコピー　　　　　　If wbDst Is Nothing Then 　　　　　　　　ActiveSheet.Copy 　　　　　　　　Set wbDst = ActiveWorkbook 　　　　　　　　fCopied = True 　　　　　　Else 　　　　　　　　ActiveSheet.Copy After:=wbDst.Sheets(wbDst.Sheets.Count) 　　　　　　End If 　　　　　　　　　　　　' // 可能ならB16の値でシート名変更、不可能なら適当な名前　　　　　　On Error Resume Next 　　　　　　ActiveSheet.Name = ActiveSheet.Range("B16").Value 　　　　　　If Err Then 　　　　　　　　ActiveSheet.Name = "Sheet" & CStr(wbDst.Sheets.Count) 　　　　　　End If 　　　　　　On Error GoTo 0 　　　　　　　　　　　　' // 値に変換(適当）　　　　　　ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 　　　　　　　　　　　　' // ソースブックを閉じる　　　　　　wbSrc.Close SaveChanges:=False 　　　　　　　　End If 　　　　' // 次を検索　　　　sFileName = Dir$() 　　Loop 　　　　Application.ScreenUpdating = True 　　Application.StatusBar = "" 　　　　If Not fCopied Then 　　　　MsgBox "該当ブックは見つからない", vbInformation, "エラー" 　　Else 　　　　MsgBox "適切な場所へ保存して下さい", vbInformation, "完了" 　　End If 　　Set wbSrc = Nothing 　　Set wbDst = Nothing End Sub

KenKen_SP · Answer

ついでの余談

このマクロの統合順番ですが、HDD のファイルシステムによって決まります。
DIR 関数がファイルを検索してくる順...ということですが、

　　FAT：　 HDDに記録されている順
　　NTFS：　ファイル名順

という違いがあります。

統合順番に意味がある場合、Win9x系、NT系 OS が混在する環境では注意が必要。

myRange · Answer

提示のコードのとおりであれば、
mb.Activateができないのはちょと不可思議な現象ですが、、、
エラーも出ないのですよね？

ま、そこに拘っていては先に進みませんので。。。。
下記のように、新ブックオブジェクトを明示してみてください。
mb.Activateは不要です。

'--------------------------------------
mb.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select

Application.DisplayAlerts = False
Windows(mb.Name).SelectedSheets.Delete
Application.DisplayAlerts = True

mb.SaveAs myfdr & "\Consolidated.xls"
mb.Close False
'--------------------------------------


また、ブック名を変数で付けたい場合は、
例えば、統合＆本日：　"統合20090609.xls"
としたければ、
'---------------------------------------
Dim NewBookName As String
NewBookName = "統合" & Format(Date, "yyyymmdd") & ".xls"
mb.SaveAs myfdr & "\" & NewBookName　
'----------------------------------------

以上ここまで。

n-jun · Answer

n-junです。

止まるというのがエラーなのかよく分かりませんが、削除に対してのメッセージなら

mb.Activate

Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

メッセージが出ないようにするとか？

yyr446 · Answer

「新しいブックをアクティブにする記述がわからず、」
解答＝＞
Set mb = Workbooks.Addとしているからmbが新しいワークブックオブジェクトです。これをアクティブにするなら、
mb.Activate
とします。mbに"hoge.xls"の名前をつけて保存するには、
mb.SaveAs("hoge.xls")
とできます。

n-jun · Answer

新しく開いたＢｏｏｋって
＞Set mb = Workbooks.Add '新しいコピー先ブックをmbとする。
これの事？

そうであれば
md.Activate
でアクティブになるかと。

新しく開いたブックをアクティブにするマクロ

こんにちは。

ついでの余談

提示のコードのとおりであれば、

n-junです。

この回答への補足

「新しいブックをアクティブにする記述がわからず、」

この回答への補足

新しく開いたＢｏｏｋって

この回答への補足

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング