下記の様なマクロを書いていますが、別のマクロの記述の仕方で短縮に書くことはできないでしょうか。
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
できれば、捺印は、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
こんなもので如何
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