業務に使える便利ツールをエクセルマクロで作成して担当者に配布した～♪

今日はエクセルマクロのおはなし。

業務で電子印をよく使用する。

担当メンバー個人の電子印ももちろん存在する。

電子印って言っても作成したものでなくて、白い紙に押印後に
スキャナで読み取って作成したもの。

回答書の作成時に担当者印を捺印するファイルや責任者印を
捺印するもの、どちらとも必要なものなど様々だ。

捺印するのはいいんだけど、まずコピーしてから貼り付けなきゃならない。

( ﾟДﾟ)ﾒﾝﾄﾞｸｾｰ

じゃあ、自動化すんべ。

でもどうやってつくろうか。。。

マクロ書くだけだったらシェープとか保存出来ないし。

。。。。。。保存？

ｿｯｶｧ(o-д-o)ゞ　別ファイルに保存してマクロで参照するように設計すればいいな！

で、作成！

恥ずかしいけど、サンプルを。。。



☆標準モジュール☆
______________________________________________________________________________________________________________



Sub RLO4Con()
    Dim tes, buf As String, wb As Workbook
    Const Target As String = 参照先ファイルパス
 
        Call RLC4Con
        buf = Dir(Target)
        If buf = "" Then
            MsgBox "「" & Target & "」は存在しません" & vbCrLf & _
                "管理者にご連絡ください" & vbCrLf & _
                "" & vbCrLf & _
                "こぴーらいと　けいくん", vbExclamation, _
                "ファイル不存在"
            Exit Sub
        End If
        For Each wb In Workbooks
            If wb.Name = buf Then
                MsgBox "「" & buf & "」はすでに開かれています" & vbCrLf & _
                    "操作が完了出来ない場合は管理者にご連絡ください" & vbCrLf & _
                    "" & vbCrLf & _
                    "こぴーらいと　けいくん", vbExclamation, _
                    "操作不可？"
                Exit Sub
            End If
        Next wb
        Workbooks.Open Target, ReadOnly:=True, Password:=パスワード
        Application.Windows(buf).Visible = False
______________________________________________________________________________________________________________


Sub RLC4Con()
    Dim tes, buf As String, wb As Workbook
    Const Target As String = 参照先ファイルパス
        buf = Dir(Target)
        For Each wb In Workbooks
            If wb.Name = buf Then
                With Application
                    .Windows(buf).Visible = True
                    .DisplayAlerts = False
                End With
                Workbooks(buf).Close
                With Application
                    .DisplayAlerts = True
                End With
                Exit Sub
            End If
        Next wb
End Sub


______________________________________________________________________________________________________________

Sub UserJ()
        On Error Resume Next
        Dim wb As Workbook
        Dim myRow1 As Long
        Dim FC As Variant
        Dim tes, buf, FName, tgt, UN, RLN, iden As String
     
        Const Target As String = 参照先ファイルパス
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        buf = Dir(Target)
        RLF = 参照先ファイル名
        UN = Environ("USERNAME")
        tgt = 情報保管場所ラベル
        For Each wb In Workbooks
            If wb.Name = RLF Then
                Set RL = Workbooks(buf).Sheets(1)
                With RL
                    myRow1 = .Cells(.Rows.Count, 2).End(xlUp).Row
                    Set FC = .Range(.Cells(1, 2), .Cells(myRow1, 2)).Find(What:=tgt)
                    tgtR = FC.Row + 1
                    Do
                        If Left(STorSE.TE.Caption, 1) = 1 Then
                            If .Cells(tgtR, 4) = 責任者情報 Then
                                Exit Do
                            End If
                        Else
                            If .Cells(tgtR, 4) = UN Then
                                Exit Do
                            End If
                        End If
                        tgtR = tgtR + 1
                    Loop While .Cells(tgtR, 3) <> "EOF"
                    iden = .Cells(tgtR, 8)
                    iden = iden & Right(選択用ユーザーフォーム.TE.Caption, 2)
                    Call TEC(iden)
                End With
                Call RLC4Con
                With Application
                    .EnableEvents = True
                    .ScreenUpdating = True
                End With
                Exit Sub
            End If
        Next wb
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        Call RLO4Con
        With STorSE
            AcB = .AcBN.Caption
            AcS = .AcSN.Caption
            AcCRs = .AcCR.Caption
            AcCCs = .AcCC.Caption
        End With
        With Workbooks(AcB)
            .Activate
            With .Sheets(AcS)
                .Activate
            End With
        End With
        Call UserJ
End Sub
______________________________________________________________________________________________________________

Sub 選択用ユーザーフォーム表示()
        Dim AcB, AcS, AcCRs, AcCCs As String
     
        AcB = ActiveWorkbook.Name
        AcS = ActiveSheet.Name
        AcCRs = ActiveCell.Row
        AcCCs = ActiveCell.Column
        With 選択用ユーザーフォーム
            .Show vbModeless
            .AcBN.Caption = AcB
            .AcSN.Caption = AcS
            .AcCR.Caption = AcCRs
            .AcCC.Caption = AcCCs
        End With
End Sub
______________________________________________________________________________________________________________
Sub TEC(ByRef iden As String)
        Dim s As Shape
        Dim buf As String
        Dim j As Long
        j = ActiveSheet.Shapes.Count
     
        Const Target As String = 参照先ファイルパス
        buf = Dir(Target)
        Set RL = Workbooks(buf).Sheets(1)
        With RL
            For i = 1 To .Shapes.Count
                If .Shapes(i).Name = iden Then
                    With .Shapes(i)
                        .Duplicate.Cut
                    End With
                    Exit For
                End If
                If i = .Shapes.Count And .Shapes(i).Name <> iden Then
                    Unload 選択用ユーザーフォーム
                    MsgBox "登録されていない為、処理を継続できません" & vbCrLf & _
                        "" & vbCrLf & _
                        "こぴーらいと　けいくん", vbCritical, _
                        "未登録"
                    Exit Sub
                End If
            Next
        End With
        With ActiveSheet
            .Paste
            Set Rng = ActiveCell
            For i = 1 To .Shapes.Count
                If .Shapes(i).Name = iden Then
                    Set s = .Shapes(i)
                    With s
                        .Top = Rng.Top + Rng.Height / 2 - .Height / 2
                        .Left = Rng.Left + Rng.Width / 2 - .Width / 2
                        .DrawingObject.Formula = ""
                        .Name = iden & "C" & j + 1
                    End With
                    Exit For
                End If
            Next
            Rng.Activate
        End With
End Sub
______________________________________________________________________________________________________________

☆ユーザーフォーム☆

______________________________________________________________________________________________________________

Private Sub mgrSE_Click()

    TE.Caption = "1SE"

    Call UserJ

    Unload Me

End Sub

Private Sub mgrST_Click()

    TE.Caption = "1ST"

    Call UserJ

    Unload Me

End Sub

Private Sub userSE_Click()

    TE.Caption = "2SE"

    Call UserJ

    Unload Me

End Sub

Private Sub userST_Click()

    TE.Caption = "2ST"

    Call UserJ

    Unload Me

End Sub

______________________________________________________________________________________________________________

これでとりあえずは、実現できたみたい。

使ってみて不具合がでなければいいなぁ。。。

さて帰ろ＾＾

最後まで読んでくれたらコメントをお願いしますm(_ _"m)ﾍﾟｺﾘ