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

解決済みの質問

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

投稿日時 - 2008-09-18 11:27:07

QNo.4337790

すぐに回答ほしいです

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

 'コピー先
  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

投稿日時 - 2008-09-20 15:06:44

補足

すみません!!

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

投稿日時 - 2008-09-22 11:57:50

ANo.7

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

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

回答(7)

ANo.6

'シート上何の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

投稿日時 - 2008-09-18 16:40:05

補足

ありがとうございます!

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

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

投稿日時 - 2008-09-19 09:32:11

ANo.5

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

  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

投稿日時 - 2008-09-18 14:45:33

補足

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

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)新しく保存したシートにもシート保護したくてコードを追加したのですが機能しません・・。

投稿日時 - 2008-09-18 15:37:12

ANo.4

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

  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
  '上記のコードは、コピー元からコピー先にコピーすると「ボタン」までコピーされるので
  'その「ボタン」を削除するコードです。
  '「ボタン」が1個しかないなら、以下のように変更してもいいです。
   ↓
  ActiveSheet.Shapes(1).Delete
  
  NewWkbook.Sheets(1).Name = StName1
  '
  FileName = "D:\保存\計画\" & FileName'←保存先のフォルダも違うなら変更する必要がある

投稿日時 - 2008-09-18 14:02:41

補足

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

投稿日時 - 2008-09-18 14:26:11

ANo.3

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

投稿日時 - 2008-09-18 12:22:46

補足

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

投稿日時 - 2008-09-18 13:31:45

ANo.2

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

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

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

投稿日時 - 2008-09-18 11:43:15

補足

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

投稿日時 - 2008-09-18 13:29:34

ANo.1

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

投稿日時 - 2008-09-18 11:39:51

補足

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

投稿日時 - 2008-09-18 13:17:39

あなたにオススメの質問