Excel2003のVBAでエクセルファイルとして保存

質問

こんにちわ。
Excel2003のVBAで、シート1に採点用のフォーマットを作成し、採点ボタンを押したら別の場所（フォルダ）に別のファイル（.xls形式）として採点結果を保存したいと考えています。過去に似たような質問があったのでそれを参考にしたのですが、コードの意味がほとんど分かりません。下記のコードで実行したところ、エラーが出てしまいます。どこが悪いのか教えていただけないでしょうか？
エラー箇所は
BkName = OldWkbook.Sheets(StName1).Range("K1").Value
です。”インデックスが有効範囲にありません”と表示されます。

例）
　 Dim FileName As String
Dim FileExt As String
Dim BkName As String
Dim OldWkbook As Workbook
Dim NewWkbook As Workbook
Const StName1 As String = "ko"

'
Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook
'
'ファイル名を取得
BkName = OldWkbook.Sheets(StName1).Range("K1").Value
FileName = BkName & Format(Now, "yyyy-mm") & ".XLS"
'
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".XLS" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If
'
OldWkbook.Sheets(Array(StName1)).Copy
Set NewWkbook = ActiveWorkbook
'シートの保護を解除
Worksheets("sheet1").Unprotect
For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
NewWkbook.Sheets(1).Shapes(wIx).Delete '←1ではなくwIxです
End If
Next

NewWkbook.Sheets(1).Name = StName1
'
FileName = "D:\保存\計画\" & FileName
'
If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
NewWkbook.Close savechanges:=False
'##保存せずに終了
Exit Sub
End If
'##指定ファイル置き換え保存
NewWkbook.SaveAs FileName:=FileName
Else
'##ファイルを新規保存
NewWkbook.SaveAs FileName:=FileName
End If
'
NewWkbook.Close savechanges:=False
Application.DisplayAlerts = True
End Sub

回答No.7

pkh4989 · ベストアンサー

'コピー先
　　With ActiveWorkbook
　　　　'シート名変更
　　　　'.Sheets(1).Name = StName1
　　　　'.Sheets(2).Name = StName2
　　　　'.Sheets(3).Name = StName3
　　　　'.Sheets(4).Name = StName4
　　　　'シート2,4のボタンを削除
　　　　'.Sheets(2).Shapes(1).Delete
　　　　'.Sheets(4).Shapes(1).Delete
　　　　'但し、シート上にボタン以外のObjectが存在する場合は、以下のように
　　　　'ボタンのみ削除する必要がある。

'↑上記は不要ですので、削除して以下のコードのみで試してみてください。

　　　　'この部分は私も分からないので、自分で変更してくださいね。
　　　　For wIx = Sheets(2).Shapes.Count To 1 Step -1
　　　　　　If Left(.Sheets(2).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
　　　　　　　　.Sheets(2).Shapes(wIx).Delete
　　　　　　End If
　　　　Next
　　　　For wIx = Sheets(4).Shapes.Count To 1 Step -1
　　　　　　If Left(.Sheets(4).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
　　　　　　　　.Sheets(4).Shapes(wIx).Delete
　　　　　　End If
　　　　Next
　　　　'シートの保護
　　　　.Sheets(1).Protect
　　　　.Sheets(2).Protect
　　　　.Sheets(3).Protect
　　　　.Sheets(4).Protect
　　End With

補足

すみません！！

　If Left(.Sheets(2).Shapes(wIx).Name, 6) = "Button" Then の
.Sheets(2)で「参照が不正または不完全です」と表示されてしまいます・・。

回答No.6

pkh4989

'シート上何のObjectが存在するか分からないので、
'自分で、研究してくださいね。(以下に例を書いてあるので)
Sub test()
　　Dim wIx　　　　 As Integer
　　Dim FileName　　As String
　　Dim FileExt　　 As String
　　Dim BkName1　　 As String
　　Dim BkName2　　 As String
　　Dim OldWkbook　 As Workbook
　　Dim NewWkbook　 As Workbook
　　Const StName1　 As String = "適材適所グラフ"
　　Const StName2　 As String = "適材適所回答"
　　Const StName3　 As String = "適性検査III回答"
　　Const StName4　 As String = "適性検査IIIグラフ"
　　'
　　'コピー元シートの保護を解除
　　Worksheets("適材適所グラフ").Unprotect
　　Worksheets("適材適所回答").Unprotect
　　Worksheets("適性検査III回答").Unprotect
　　Worksheets("適性検査IIIグラフ").Unprotect

　　Application.DisplayAlerts = False
　　Set OldWkbook = ActiveWorkbook
　　'
　　'ファイル名を取得
　　BkName1 = OldWkbook.Sheets(StName3).Range("J1").Value
　　BkName2 = OldWkbook.Sheets(StName3).Range("K1").Value
　　FileName = BkName1 & Format(".") & BkName2 & Format(Now, "yyyy-mm-dd") & ".xls"
　　'
　　FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
　　If FileName = "" Then
　　　　Exit Sub
　　Else
　　　　If Right(FileName, 4) <> ".xls" Then
　　　　　　MsgBox "ファイル名が異常です。"
　　　　　　Exit Sub
　　　　End If
　　End If

　　OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy

　　Set NewWkbook = ActiveWorkbook
　　'コピー先
　　With ActiveWorkbook
　　　　'シート名変更
　　　　.Sheets(1).Name = StName1
　　　　.Sheets(2).Name = StName2
　　　　.Sheets(3).Name = StName3
　　　　.Sheets(4).Name = StName4
　　　　'シート2,4のボタンを削除
　　　　.Sheets(2).Shapes(1).Delete
　　　　.Sheets(4).Shapes(1).Delete
　　　　'但し、シート上にボタン以外のObjectが存在する場合は、以下のように
　　　　'ボタンのみ削除する必要がある。
　　　　'この部分は私も分からないので、自分で変更してくださいね。
　　　　For wIx = Sheets(1).Shapes.Count To 1 Step -1
　　　　　　If Left(.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
　　　　　　　　.Sheets(1).Shapes(wIx).Delete
　　　　　　End If
　　　　Next
　　　　For wIx = Sheets(4).Shapes.Count To 1 Step -1
　　　　　　If Left(.Sheets(4).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
　　　　　　　　.Sheets(4).Shapes(wIx).Delete
　　　　　　End If
　　　　Next
　　　　'シートの保護
　　　　.Sheets(1).Protect
　　　　.Sheets(2).Protect
　　　　.Sheets(3).Protect
　　　　.Sheets(4).Protect
　　End With
　　'
　　FileName = "C:\採点結果\" & FileName
　　'
　　If Dir(FileName) <> "" Then
　　　　'##ファイルが既に存在する
　　　　If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
　　　　　　NewWkbook.Close savechanges:=False
　　　　　　'##保存せずに終了
　　　　　　Exit Sub
　　　　End If
　　　　'##指定ファイル置き換え保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　Else
　　　　'##ファイルを新規保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　End If
　　'
　　NewWkbook.Close savechanges:=False
　　Application.DisplayAlerts = True
　　'
　　'コピー元シートの保護
　　Worksheets("適材適所グラフ").Protect
　　Worksheets("適材適所回答").Protect
　　Worksheets("適性検査III回答").Protect
　　Worksheets("適性検査IIIグラフ").Protect
End Sub

補足

ありがとうございます！

Sheets(3).Name = StName3
ここだけオートメーションエラーと表示されてしまいます・・。なぜ1、2、が平気でここだけなのでしょうか？

.Sheets(2).Shapes(1).Delete
ここでアプリケーション定義またはオブジェクトのエラーですと表示されます・・。

回答No.5

pkh4989

以下のように追加・変更してください。

　　Const StName1　 As String = "Sheet1"
　　Const StName2　 As String = "Sheet2"
　　Const StName3　 As String = "Sheet3"
　　Const StName4　 As String = "Sheet4"

　　OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy

補足

何度も答えていただき本当にありがとうございます！！
あともう二点ほど聞きたい箇所があります。

Dim FileName As String
Dim FileExt As String
Dim BkName1 As String
Dim BkName2 As String
Dim OldWkbook As Workbook
Dim NewWkbook As Workbook
Const StName1 As String = "適材適所グラフ"
Const StName2 As String = "適材適所回答"
Const StName3 As String = "適性検査III回答"
Const StName4 As String = "適性検査IIIグラフ"

'シートの保護を解除
Worksheets("適性検査III回答").Unprotect
Worksheets("適材適所回答").Unprotect

Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook
'
'ファイル名を取得
BkName1 = OldWkbook.Sheets(StName3).Range("J1").Value
BkName2 = OldWkbook.Sheets(StName3).Range("K1").Value
FileName = BkName1 & Format(".") & BkName2 & Format(Now, "yyyy-mm-dd") & ".xls"
'
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".xls" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If

OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy

Set NewWkbook = ActiveWorkbook

'ボタンを削除
For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
NewWkbook.Sheets(1).Shapes(wIx).Delete
End If
Next

NewWkbook.Sheets(1).Name = StName1
Sheets(1).Protect

'
FileName = "C:\採点結果\" & FileName
'
If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
NewWkbook.Close savechanges:=False
'##保存せずに終了
Exit Sub
End If
'##指定ファイル置き換え保存
NewWkbook.SaveAs FileName:=FileName
Else
'##ファイルを新規保存
NewWkbook.SaveAs FileName:=FileName
End If
'
NewWkbook.Close savechanges:=False
Application.DisplayAlerts = True

'シートの保護
Worksheets("適性検査III回答").Protect

End Sub

1）シート2とシート4にあるボタンだけ削除したいです。
2）新しく保存したシートにもシート保護したくてコードを追加したのですが機能しません・・。

回答No.4

pkh4989

以下のように変更してみてください。

　　OldWkbook.Sheets(Array(StName1)).Copy
　　Set NewWkbook = ActiveWorkbook

'　　'シートの保護を解除
'　　Worksheets("sheet1").Unprotect
'　　'ボタンを削除
'　　For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
'　　　　If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
'　　　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete '←1ではなくwIxです
'　　　　End If
'　　Next
　　'上記のコードは、コピー元からコピー先にコピーすると「ボタン」までコピーされるので
　　'その「ボタン」を削除するコードです。
　　'「ボタン」が１個しかないなら、以下のように変更してもいいです。
　　　↓
　　ActiveSheet.Shapes(1).Delete

　　NewWkbook.Sheets(1).Name = StName1
　　'
　　FileName = "D:\保存\計画\" & FileName '←保存先のフォルダも違うなら変更する必要がある

補足

ご回答ありがとうございます。
実行したところ、保存できました！！
ですが、これを一つのシートではなく複数のシートを保存したいのですが可能でしょうか？
マクロを実行したブックには全部で4つのシートがあり、先ほどのコードで実行したら、そのマクロ（採点ボタン）があるシートしか保存されていなかったので、マクロを実行したら全4つのシートを保存したいと考えています。

回答No.3

n-jun

提示されたコードは質問者さんの環境に合わせて修正したものですか？
或いは過去ログからそのままコピペして実行したのですか？

補足

ご回答ありがとうございます。
過去ログからコピペしたものなので、ANo.1さん、ANo.2さんが指摘している通り、"ko"というシートが存在していませんでした。ただ、存在しているシート名にしてもANo.1さんに補足したエラーが表示されてしまいました。

回答No.2

kokorone

分からないから、人に聞く　のでは、進歩がありません。
まずは、使われている命令について、調べてください。
どこが悪いのかは、エラー行がでていますよね。

ご自分のワークブックと、拾ってきたＶＢＡの環境が異なれば、
実行時にエラーが出るのは当然です。

"ko"というシートが存在しないのでは？？

補足

ご回答ありがとうございます。
仰る通り、"ko"というシートが存在していませんでした。

回答No.1

higekuman

マクロを実行したワークブックに、ko という名前のワークシートは存在しますか？

補足

ご回答ありがとうございます。
koというワークシートが存在していなかったため、マクロを実行したワークブックにあるシート名にして実行したところ、
NewWkbook.Sheets(1).Shapes(wIx).Delete
”アプリケーション定義またはオブジェクト定義のエラー”と表示されてしまいます・・。