excel2000マクロについて

下記の様なマクロを書いていますが、別のマクロの記述の仕方で短縮に書くことはできないでしょうか。

Sub 承認捺印()
Sheets("実行").Select
If Range("E13").Value = "申請者" Then

Sheets("ログイン").Select
If Range("F11").Value = "a8012661" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 15").Copy
Call 申請者捺印
End If

If Range("F11").Value = "a6601456" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 16").Copy
Call 申請者捺印
End If

If Range("F11").Value = "t9907028" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 17").Copy
Call 申請者捺印
End If

If Range("F11").Value = "a7545410" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 18").Copy
Call 申請者捺印
End If

If Range("F11").Value = "t9806047" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 19").Copy
Call 申請者捺印
End If

If Range("F11").Value = "t0206030" Then
Sheets("印章").Select
ActiveSheet.Shapes("Picture 20").Copy
Call 申請者捺印
End If
　end if

end sub

Sub 申請者捺印()
Sheets("報告票").Select
Range("m3").Select
ActiveSheet.Paste

Range("a1").Select
End Sub

No.2 ベストアンサー 回答者： Wendy02 回答日時： 2005/06/09 21:04

できれば、捺印は、Copy よりも、jpg などの別ファイルにして、挿入したほうが問題が少ないです。

私の経験では、オブジェクトの貼り付け削除の繰り返しを千回以上になると、時々、トラブルを起こすことがあります。

また、Option Base の　1　とは共用する場合は、
myValue = Array(.. , .. , ..)
lastindex = UBound(ar) - 1
ReDim Preserve myValue(0 To lastindex)
とひとつずらすか、"Picture " & i + 14 にしてください。

'<標準モジュール>

Sub 承認捺印()
　Dim myValue As Variant
　Dim ShapeName As String, i As Long
　'配列による設定
　myValue = Array("a8012661", "a6601456", "t9907028", "a7545410", "t9806047", "t0206030")
　
　　If Sheets("実行").Range("E13").Value = "申請者" Then
　　　For i = LBound(myValue) To UBound(myValue)
　　　　If Sheets("ログイン").Range("F11").Value = myValue(i) Then
　　　　　ShapeName = "Picture " & i + 15
　　　　　Sheets("印章").Shapes(ShapeName).Copy
　　　　　With Sheets("報告票")
　　　　　　 Application.Goto .Range("m3")
　　　　　　 .Paste
　　　　　　 'オブジェクトが見えなくなることがあるのでVisibleをTrue
　　　　　　 .Shapes(ShapeName).Visible = msoTrue
　　　　　　 .Range("A1").Select
　　　　　　 Exit For
　　　　　 End With
　　　　End If
　　　Next
　　End If
End Sub

No.3 回答者： imogasi 回答日時： 2005/06/09 23:45

（１）まずマクロの記録に由来するかと思うＳＥＬＥＣＴはやめてはどうですか

Sheets("ログイン").Select
If Range("F11").Value = "a8012661" Then
はSheets("ログイン").Range("F11")= "a8012661" Then
（２）ＶＡＬＵＥも省略しては
反対のかたもいるかも知れないが。
（３）私はＡＲＲＡＹを２つ作り、同順序に並べてよくやります。
a=Array("a8012661","a6601456",・・・)
b=Array("15","16",・・・）
aを探して何番目かわかった場合にｂの何番目かのデータを取るという風に。
あまり数が多いと使いませんが。
多いときは対応表をファイルとしてもち、最初に読んで配列に入れて同じことをやります。

No.1 回答者： mshr1962 回答日時： 2005/06/09 19:45

こんなもので如何

Sub 承認捺印()
Sheets("印章").Select

If Worksheets("実行").Range("E13").Value = "申請者" Then
　Select Case Worksheets("ログイン").Range("F11").Value
　Case "a8012661"
　　ActiveSheet.Shapes("Picture 15").Copy
　
　Case "a6601456"
　　ActiveSheet.Shapes("Picture 16").Copy

　Case "t9907028"
　　ActiveSheet.Shapes("Picture 17").Copy

　Case "a7545410"
　　ActiveSheet.Shapes("Picture 18").Copy

　Case "t9806047"
　　ActiveSheet.Shapes("Picture 19").Copy

　Case"t0206030"
　　ActiveSheet.Shapes("Picture 20").Copy

　Case Else
　　Exit Sub

　End Select
　　Call 申請者捺印
End If

End Sub