Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


10879 / 13646 ツリー ←次へ | 前へ→

【19409】印刷のマクロ shiki 04/10/31(日) 22:12 質問[未読]
【19410】Re:印刷のマクロ かみちゃん 04/11/1(月) 7:25 回答[未読]
【19424】Re:印刷のマクロ shiki 04/11/1(月) 19:09 お礼[未読]

【19409】印刷のマクロ
質問  shiki  - 04/10/31(日) 22:12 -

引用なし
パスワード
   セルにsheet名が入力されると、そのsheetが印刷されるマクロを作りたいのですが、わかりません。どのようにすればよいのでしょうか?

例 A1セルに"月曜日"と入力された場合、月曜日というsheetを印刷する
  A2セルに"火曜日"と入力された場合、火曜日というsheetを印刷する
  A3セルに"水曜日"と入力された場合、水曜日というsheetを印刷する

というマクロです。お願いします

【19410】Re:印刷のマクロ
回答  かみちゃん  - 04/11/1(月) 7:25 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>セルにsheet名が入力されると、そのsheetが印刷されるマクロを作りたい

次のような感じになるかと思います。
あらかじめ、A1〜A3など、印刷したいシートが入力されているセルを選択した状態でMacro1を実行してください。

Option Explicit

Sub Macro1()
 Dim c As Range
 Dim StartSheetName As String
 
 StartSheetName = ActiveSheet.Name
 '選択している範囲を印刷対象シートが入力しされているセルとする。
 For Each c In Selection
  'シートが存在するかどうかをチェックする。
  If chkSHEET(c.Value) Then
   Sheets(c.Value).Select
   'シートが存在したら印刷する
   ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
  Else
   MsgBox c.Address & "に入力してある" & c.Value & "というシートは存在しません。"
  End If
 Next
 Sheets(StartSheetName).Select
 Range("A1").Select
End Sub

'シート名存在チェック
'http://www.ken3.org/backno/backno_vba19.html#92
' シート名を受け取り、
' 判断結果をTrue , Falseで返す関数
'
'関数名:  chkSHEET
'入力値:  シート名文字列
'戻り値 :シートの有無・結果
'処理概要: シート名をパラメーターで受け取り、
'     アクティブなブック内に存在するかを確認し、
'     結果のTrue , Falseを戻り値で返す
Function chkSHEET(strSNAME As String) As Boolean

 Dim MyObject As Object

 'ブック内のシート名の比較を行う
 For Each MyObject In ThisWorkbook.Sheets
  '.Nameプロパティのシート名と受け取ったstrSNAMEを比べる
  If MyObject.Name = strSNAME Then
   chkSHEET = True '名前が一致したのでTrueをセット
   Exit Function  'もうすること無いので関数を抜ける
  End If
 Next

 '一つも一致しなかったので、Falseをセット
 chkSHEET = False

End Function

なお、シート名が入力されているセルがA1〜A3など、あらかじめ決まっている場合は、
 For Each c In Selection
という部分を
 For Each c In Range("A1:A3")
と変更していただければ、いいです。

【19424】Re:印刷のマクロ
お礼  shiki  - 04/11/1(月) 19:09 -

引用なし
パスワード
   ▼かみちゃん さん:
>ありがとうございました。やってみます

10879 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free