Excel2010のVBAで起動時に連番表示＆保存

Question

【再掲載＆追加情報です】

ずっとwindowsXP　SP3を使用していたのですが（Excel2002　SP3もそのまま）
今回急遽社内のパソコンが2台（1台は自分のです）だけWindows7に変わりました。

その2台だけExcelも2002から2010に変わったのですが、使用しているファイルで記述してる
FileSearchが使えないとあとから知りました。（泣）
ネットで検索してFileSystemObjectを代わりに使用するというのを知りましたが
初心者の為理解が難しく・・・。
申し訳ありませんが記述の変更方法を教えていただけないでしょうか？

（１）フォルダーは　”C:\指示\記入済”　に出来たExcelファイルを保存してます
（２）番号は指定フォルダ内のエクセルファイルをカウントしてその数＋1を
　　U1のセルに表示させています。
（３）作成した保存ボタンで新見積書を保存する
　　　但し、マクロコードとボタンを削除したものを保存する
（４）新見積書の保存後はブック、エクセルともに終了する

**************現在使用中データ**************

--- Module1 ----

Public Const FPath = "C:\指示\記入済"
'xlsファイル検索
Sub Auto_Open()
With Application.FileSearch
.NewSearch
.Filename = "*.xls"
.FileType = msoFileTypeAllFiles
.LookIn = FPath
.SearchSubFolders = False
.Execute

Cells(1, 21).Value = .FoundFiles.Count + 1
Cells(1, 21).NumberFormat = "0000"
End With
End Sub

--- Module2 ----

Sub ファイルに名前を付けて保存()
　Dim 既定ファイル名 As String
　Dim 保存ファイル名 As Variant

既定ファイル名 = FPath & "\" & Range("T1") & Format(Range("U1"), "0000") & Range("B1") & ".xls"

保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名)

If 保存ファイル名 = False Then
　　　　MsgBox "保存は中止されました"
　　　　Exit Sub
　　End If

ActiveWorkbook.SaveCopyAs 保存ファイル名

Dim NewBook As Workbook
　Set NewBook = Workbooks.Open(保存ファイル名)

Dim myVBA As Object
　For Each myVBA In NewBook.VBProject.VBComponents
　　　With myVBA
　　　　If .Type = 100 Then
　　　　　.CodeModule.DeleteLines 1, .CodeModule.CountOfLines
　　　　Else
　　　　　Application.VBE.activeVBProject.VBComponents.Remove myVBA
　　　　End If
　　　End With
　Next myVBA

NewBook.ActiveSheet.Shapes(1).Delete
　NewBook.Close True

'●●●
　Set NewBook = Workbooks.Open(保存ファイル名)
　NewBook.Close True
'●●●

'ブックとエクセル終了
　Application.Quit
　ThisWorkbook.Close False

End Sub

********************************************

上記がExcel2002で問題なく動いている記述です。

最初Excel2010で起動してエラーが出たので検索したとき、てっきりFileSearchだけが問題
だと思っていたのですがもしかして他にもあったのでしょうか？

--- Module1 ----は、先ほど質問したときに

Public Const FPath = "C:\指示\記入済"
'xlsファイル検索
Sub Auto_Open()
Dim tmp as String
Dim i as Long

tmp = Dir(FPath & "¥*.xls")

Do While tmp <> "" 
i = i + 1
tmp = Dir()
Loop

Cells(1, 21).Value = i+1
Cells(1, 21).NumberFormat = "0000"

End Sub

に変更したら動くようになりました。

ただ、作成した保存ボタンを押すと指定した場所に指定したセルの文字を拾って
ファイル名を表示させるまでマクロに登録（Module2）したのですが、
指定したフォルダは開いてるのですがファイル名が空欄のままです。

更にそれに手打ちでファイル名を打ち、保存すると
実行時エラー1004
プログラミングによるVisualBasicプロジェクトへのアクセスは信頼性に欠けます
と表示されます・・・。
デバックを押すと
For Each myVBA In NewBook.VBProject.VBComponents
の部分が黄色くなってました＞＜

他に情報としては
このファイルはxlt（テンプレート）にしています。
使用者たちにはファイル名を打たせないように上記のようにしました。
再度宜しくお願いします・・・。
何度もお手数をおかけしまして申し訳ありません。。。

MSZ006 · Accepted Answer

ひとつ目「保存ファイル名の欄が空欄のまま」については、自信がないのですが、モジュール２の

保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名)

の行を、

保存ファイル名 = Application.GetSaveAsFilename(InitialFileName:= 既定ファイル名)
としてみてください。

ふたつ目、「プログラミングによる Visual Basic プロジェクトへのアクセスは信頼性に欠けます」については、エクセル2010自体のセキュリティの設定の問題だと思います。下記の設定をしてみてください。

「ファイル」タブを選択
画面左の「オプション」を選択
ダイアログ左の「セキュリティ センター」を選択
ダイアログ右の「セキュリティ センターの設定」ボタンを選択
ダイアログ左の「マクロの設定」 を選択
ダイアログ右の「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」のチェックボックスにチェックを入れる

cj_mover · Answer

こんにちは。お邪魔します。

ご提示の Sub ファイルに名前を付けて保存()、についてですが、
処理の内容としては、アクティブブックのコピーを取ってから、
VBAの記述と追加されているモジュールとシート上のShapeを削除する、
というものになっています。
わざわざVBIDE操作をする必要はないと思いますが、
VBAの記述を操作する、ということは、プログラムを書き換える、ということを意味します。
Excelを含む大抵のアプリケーションにおいて、容易に書換えが出来ない様に
保護する仕組みが予め用意してあります。
Excel VBAからVBAの内容を取得したり書き換えたりするには
セキュリティレベルを大甘にして、
ＰＣに紛れ込んでいるかも知れない善からぬプログラムに対しても無抵抗な状態
に設定を変更する必要があります。
ただ、セキュリティというのは、部分的に評価できるものではありませんから、
そうした無防備な状態であっても問題ないであろう環境もあろうかとは思います。
とはいえ、プログラムを書き換える、という意味においては、
決して他人に薦められるようなものではありませんし、
職場でそのようなプログラムを許可してもいいものか（私周辺では軒並み厳禁ですが）、
という議論も当然あることでしょう。
私個人としては、そういったコードは
他に方法がない非常に特殊な場合の、私的な用途に限って扱われるべきもの
と考えています。
まぁでも人それぞれ事情はおありでしょうから、考えを押し付けるつもりもありません。
ただ、現実的な問題として、個々のＰＣ環境について、
Excelのセキュリティ設定を変更しないと機能しない、というのでは、
ちょっと扱い難い、というか、できれば避けたい、のではないでしょうか。
以上のような考えを元に、平易な方法でも実現できることを
提案してみようと思います。

新規のブックを追加（予めシート数を合わせておく）
　元となるブックのすべてのワークシートをループして
　　元となる各シートのセル範囲をコピーしたものを
　　新規ブックの対応するシートのセル範囲に貼り付ける
　　（シェープはコピーしない）
　元となるブックのアクティブシートに対応する　
　　シートを新規ブック側でアクティブにする
　保存ファイル名を指定して.Save　（閉じる？）
　Excelを終了

というような処理内容です。
処理は少し増えますが、セキュリティ設定を変更する必要はありません。
> 　　　但し、マクロコードとボタンを削除したものを保存する
ＶＢＡ（マクロ）とシェープ（ボタン）以外をコピーする、という風に解釈替えをしています。

（例外的に、グラフシートについては今回は無いものとして書いています。
　あるならあるで、少し書き加えれば対応出来ますけれど）

Application.GetSaveAsFilename　の扱いは正しました。

> 実行時エラー1004
> プログラミングによるVisualBasicプロジェクトへのアクセスは信頼性に欠けます
このエラーは起こりようがないように書きました。

xl2010では動作確認していますが、旧バージョンは未確認です。
何か問題があれば補足してみてください。
もしエラーが出る場合は、呼び出し元のボタンが、
フォームコントロールなのか、ActiveXコントロールなのか、によっても
対処が変わる場合があります。

なんだかんだ、標準的な、ベタな、処理しかしていませんが、
よりメンテし易い、質問した時にも答えられる人の多い、内容にはなっていると思います。

尚、Sub Auto_Open()、についてはこちらからは触れません。既に解決済と考えています。

' ' --- Module2 ----

Sub ファイルに名前を付けて保存()
　　Dim 既定ファイル名 As String
　　Dim 保存ファイル名 As Variant

既定ファイル名 = FPath & "\" & Range("T1") & Format(Range("U1"), "0000") & Range("B1") & ".xls"
　　保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名, "Excelファイル,*.xls")
　　If 保存ファイル名 = False Then
　　　　MsgBox "保存は中止されました"
　　　　Exit Sub
　　End If

Dim NewBook As Workbook
　　Dim oWsht As Worksheet
　　Dim nShtInNew As Long
　　Dim bCopyObj As Boolean
　　Dim i As Long

With ActiveWorkbook

nShtInNew = Application.SheetsInNewWorkbook　　'　　●シート数
　　　　Application.SheetsInNewWorkbook = .Worksheets.Count　　'　　●シート数
　　　　Set NewBook = Workbooks.Add　　'　　新規ブック
　　　　Application.SheetsInNewWorkbook = nShtInNew　　'　　●シート数

bCopyObj = Application.CopyObjectsWithCells　　'　　●コピー_オブジェクト？
　　　　Application.CopyObjectsWithCells = False　　'　　●コピー_オブジェクト？
　　　　For Each oWsht In .Worksheets
　　　　　　i = i + 1
　　　　　　oWsht.Cells.Copy NewBook.Worksheets(i).Cells(1)　　'　　シートからシート、セル範囲をコピペ
　　　　Next
　　　　Application.CopyObjectsWithCells = bCopyObj　　'　　●コピー_オブジェクト？

NewBook.Sheets(.ActiveSheet.Index).Activate

End With

Application.DisplayAlerts = False
　　NewBook.SaveAs 保存ファイル名, xlExcel8　　'　　新規に作成したブックを保存ファイル名で保存
　　Application.DisplayAlerts = True

'　　MsgBox "保存しました"
　　NewBook.Close

' ' ブックとエクセル終了
　　Application.Quit
End Sub

Excel2010のVBAで起動時に連番表示＆保存

ひとつ目「保存ファイル名の欄が空欄のまま」については、自信がないのですが、モジュール２の

こんにちは。

似たような質問が見つかりました

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

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

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