Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
"00"原本で組んだマクロのシート名を自動で変更したい
投稿日時: 21/08/05 11:43:35
投稿者: yupi

初めまして。
本当に困っています。いつもやりたい機能のマクロをつぎはぎして作成しているので解決策がわかりません。何卒ご教授お願いいたします。
 
社員の出退勤簿のExcelです。
基本の項目を”設定”シートに。
”00”シートを原本としてやりたい機能やマクロを組んでいます。
ある月の曜日や基本情報をセットしたら、一括で25人分のシートをコピーします。
あとはそれぞれの出退勤を入力するだけにしています。
ところが承認印のマクロでシート名を固定にしてしまったため、25人分のシートで承認クリックすると
当然ながらエラーになります。
 
31日分あるので、1日分だけ明記します。
 
Private Sub Worksheet_BeforeDoubleClick(ByVal _
                                 Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("r10:r11")) Is Nothing Then
    Cancel = True
    Call Macro1
 
これで呼び出します。
 
Sub Macro1()
   Dim pw As Long
   pw = Application.InputBox( _
     prompt:="承認する場合はパスワードを入力してください", Type:=1)
  If pw <> "1169" Then
     MsgBox "パスワードが違います。"
     Exit Sub
  Else
     MsgBox "承認しました"
  End If
'
' Macro1 Macro
'
    Sheets("設定").Select
    ActiveSheet.Shapes.Range(Array("Picture 4")).Select
    Selection.Copy
    Sheets("00").Select ←ここ!
    Range("r10:r11").Select
    ActiveSheet.Pictures.Paste.Select
    Selection.ShapeRange.IncrementTop 0.6522047244
    Selection.ShapeRange.IncrementTop 0.6522047244
    Selection.ShapeRange.IncrementTop 0.6522047244
    Selection.ShapeRange.IncrementLeft 0.6522047244
    Selection.ShapeRange.IncrementLeft 0.6522047244
    Range("r10:r11").Select
End Sub
 
承認者のパスワード入れると陰影が張り付くはずなんですが、
”00”原本を固定にしてしまったため、他のシートでは動きません。
25人分×31日分のマクロを作るのは死の作業です。
 
何とぞ”00”シート名が自動で”01”〜”25”になる方法を教えてください!
ちなみに貼り付け位置が何行もあるのは「マクロを記憶」で張り付けたからです。
 
参考として承認取り消しのマクロです。
ElseIf Not Intersect(Target, Range("q10")) Is Nothing Then
    Cancel = True
    Call 図形削除1
 
Sub 図形削除1()
Dim Obj As Object
 Dim Cnt As Long
 For Each Obj In ActiveSheet.DrawingObjects
 If Not Intersect(Obj.TopLeftCell, Range("r10:r11")) Is Nothing Then
 Obj.Delete
 Cnt = Cnt + 1
 End If
 Next
 If Cnt > 0 Then
 MsgBox Cnt & " 個の承認印を変更しました。", vbInformation
 Else
 MsgBox "変更対象の承認印はありません。", vbExclamation
 End If
 End Sub
 

回答
投稿日時: 21/08/05 11:58:39
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:
何とぞ”00”シート名が自動で”01”〜”25”になる方法を教えてください!

 
01〜25
とは、なんですか?
どの時点で、それを認識できますか?

投稿日時: 21/08/05 12:10:52
投稿者: yupi

早速のご対応ありがとうございます。
 
01〜25とは25人分のシート名です。
”一覧”シートに
01 ○○✖✖
02 ■■△△
    .
    .
    .
という風に各人の出退勤、残業などが反映されます。
 
Sheets("00").Select ←ここで”00”原本シート指定してしまっているから認識できないのだと思います。

投稿日時: 21/08/05 12:12:31
投稿者: yupi

この部分を自動で変更させたいのです。

回答
投稿日時: 21/08/05 14:35:24
投稿者: Suzu

説明が理解が十分とは言い切れませんが
 
多分、行いたいのは、こんな事かと。。
 
WorkSheetクラスの Worksheet_BeforeDoubleClick を使っている様ですが
それだと、各シートに記載しないといけませんので、管理が大変です。
 
処理としては、共通っぽいので、
ThisWorkBook クラス の Workbook_SheetBeforeDoubleClick に記載し
ダブルクリックを行った シート名と、Range を確認し、処理を行えば 良いでしょう。
 
 
で、、、一日分と言うことなので。。31日分コードを書いて居るのですか?
 Range("R10:R11") の部分が、1日の分 であると判断しました。
   R12:R13 が 2日の分 であるなら、共通化できます。
 
 
'ThisWorkbook クラス
 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim dtm As Date
 
  'ダブルクリック操作 を行ったシート名を特定
  ' シート名が、2文字 かつ 数値と判断できるか
  If Len(Sh.Name) = 2 And IsNumeric(Sh.Name) Then
    ' シート名が、0 から 25 の間か
    If CInt(Sh.Name) >= 0 And CInt(Sh.Name) <= 25 Then
   
      'ダブルクリック操作 を行った列が、18列目 (R列)であるか 確認
      If Target.Column = 18 Then
 
        'シート の A1 に 西暦年
        'シート の A2 に 月
        ' が入っている
          'その時の 月初日 を取得 し、変数 dtm に代入
        dtm = DateSerial(Sh.Range("A1"), Sh.Range("A2"), 1)
 
      '10行目から、71行目 までが ダブルクリックの対象範囲
      ' 10、11行目 が、1日
      ' 12、13行目 が 2日
      ' :
      ' 70、71行目 が 31日 のデータ
      '   ⇒ 対象行数 /2 の整数部分 -4 が 行数から、日付を得る 計算式 となる
 
      ' そのうち、dtm の年月 により、月末日が変わるので
      ' ダブルクリックを行ったのが、その 月末日 以下の行であれば処理を行う
 
        If Format(DateSerial(Sh.Range("A1"), Sh.Range("A2"), Target.Row \ 2 - 4), "yyyymm") = Format(dtm, "yyyymm") Then
 
          '月末日以前
          'ワークシート 設定内の Shepe『Picture 4』 をコピー
          Worksheets("設定").Shapes("Picture 4").Copy
 
          '対象処理シートに貼り付け
          With Sh.Pictures.Paste
            '貼り付けを行った Shape を移動
            .ShapeRange.IncrementTop 0.6522047244
          End With
 
          'セルが選択されるのをキャンセル
          Cancel = True
        End If
      End If
    End If
  End If
End Sub
 
 
前提条件が違ったりで修正が必要であれば、ご自分で調べてやってみましょう。

投稿日時: 21/08/05 15:17:44
投稿者: yupi

Suzu 様
 
できました!!!
ありがとうございます。(泣)
 
稚拙な説明をしっかりと汲んで頂き感謝します。
色々と自分なりに修正しましたけど、根本が良くわからないので
何故出来たのか、これからコードやプロセスを調べてみます!
 
本当にありがとうございました\(^o^)/