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

質問

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

マクロ初心者です。

マクロを使って同階層にあるファイルのアクティブのシートを
ひとつのブックにコピーして保存するマクロを作りたいと思ってます。
他の質問を参照して下記のコードを途中まで作成しました。

参照した質問では、
マクロの入っているブックにシートをコピーするようでしたが、
そうすると保存した時にマクロも保存されてしまうので
私なりに調べて、新しいブックにシートコピーするようにしましたが、
この記述の後、新しいブックをアクティブにする記述がわからず、
保存できなくなってしまいました。

ここまで終わるとマクロの入っているブックがアクティブになって終わります。
このあと新しく開いたブックをアクティブにして、
ブックの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 '繰り返す

・
・
・
・

回答No.5

KenKen_SP · ベストアンサー

こんにちは。

こんな感じにすれば不要なブランクシートはできません。
シート名を変更する際の簡単なエラートラップはついで。

余談になりますけど、

> 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

お礼

大変勉強になりました！

もともとの構文自体もほかの質問から持ってきたものを
自分でここだと思われるところを適当に直しただけで、
何が悪かったのかさっぱりわかりませんでした・・

今回ご指南いただいたマクロを元に、勉強したいと思います。
本当にありがとうございました。

回答No.6

KenKen_SP

ついでの余談

このマクロの統合順番ですが、HDD のファイルシステムによって決まります。
DIR 関数がファイルを検索してくる順...ということですが、

　　FAT：　 HDDに記録されている順
　　NTFS：　ファイル名順

という違いがあります。

統合順番に意味がある場合、Win9x系、NT系 OS が混在する環境では注意が必要。

お礼

自分自身、もっと理解を深める必要がありますね・・
OSの件は確認してみます。

ありがとうございました。

回答No.4

myRange

提示のコードのとおりであれば、
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　
'----------------------------------------

以上ここまで。

お礼

お助けいただき、ありがとうございます。
みなさまのおかげで無事解決しました。
また分からないことが発生しましたら質問させていただきます！

回答No.3

n-jun

n-junです。

止まるというのがエラーなのかよく分かりませんが、削除に対してのメッセージなら

mb.Activate

Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

メッセージが出ないようにするとか？

お礼

お助けいただき、ありがとうございます。
みなさまのおかげで無事解決しました。
また分からないことが発生しましたら質問させていただきます！

補足

説明文がつたなくてすみません。

mb.Activate

この命令でマクロが動いてくれないのです。。

なぜだか見当もつきません。
もし他の指定方法がありましたら
ご伝授ください。

回答No.2

yyr446

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

お礼

お助けいただき、ありがとうございます。
みなさまのおかげで無事解決しました。
また分からないことが発生しましたら質問させていただきます！

補足

さっそくのご解答ありがとうございます。

上記の構文に書き足してみましたが、
なぜだか止まってしまうのです。。
新しいブックにいくことが出来ません。
何か書き方が悪いのでしょうか・・

mb.Activate

Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Sheets("Sheet3").Activate
ActiveWindow.SelectedSheets.Delete

回答No.1

n-jun

新しく開いたＢｏｏｋって
＞Set mb = Workbooks.Add '新しいコピー先ブックをmbとする。
これの事？

そうであれば
md.Activate
でアクティブになるかと。

お礼

お助けいただき、ありがとうございます。
みなさまのおかげで無事解決しました。
また分からないことが発生しましたら質問させていただきます！

補足

さっそくのご解答ありがとうございます。

上記の構文に書き足してみましたが、
なぜだか止まってしまうのです。。
新しいブックにいくことが出来ません。
何か書き方が悪いのでしょうか・・

mb.Activate

Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Sheets("Sheet3").Activate
ActiveWindow.SelectedSheets.Delete