Help us understand the problem. What is going on with this article?

VBA自分ルール

・シートモジュールのマクロはシートに閉じたPrivateクラスとして構成
・ThisWorkbookモジュールのマクロは各シート間に渡る処理
・標準モジュールのマクロは共通処理
・クラスモジュールのマクロは共通処理でクラス化が妥当のもの

・変数や関数名は可能な限り2バイト日本語
・Function名はF_関数名
・Sub名はS_関数名
・関数内変数はv_変数名
・関数の引数はp_変数名
・グローバル変数はg_変数名
・Const変数?はc_変数名
・配列変数はa_変数名
・大量のセルを扱う場合は配列変数で
・書式なしコピーは Range("A1:A100").Value = Range("B1:B100").Value

命名規則の標準化で、変数一覧、未使用変数チェック、メソッド一覧、メソッド関連図を自動生成
変数や関数に日本語を使用して、説明コメントを削減
納品時にErl用行番号、On Error Gotoの自動付与とデバッグ時の自動付与行番号の削除を自動化

以下自分ルールは適用していません・・汗

Erlを使うための行番号挿入と削除

Const vbext_ct_StdModule As Variant = 1
Const vbext_ct_MSForm As Variant = 2
Const vbext_ct_ClassModule As Variant = 3
Const vbext_ct_ActiveXDesigner = 11
Const vbext_ct_Document = 100

Dim lno As Integer
Dim cmdStr As String
Dim cmCnt As Integer

Sub smdStrAdd(txt)
    cmCnt = cmCnt + 1
    cmdStr = cmdStr & txt & vbNewLine
End Sub


Public Sub トラップコード削除()
    If MsgBox(ActiveWorkbook.Name & vbNewLine & _
        "のトラップコード削除", vbExclamation + vbOKCancel) = vbCancel Then
        Exit Sub
    End If

    With ActiveWorkbook.VBProject
        For Each c In .VBComponents
            Select Case c.Type
            Case vbext_ct_StdModule
            Case vbext_ct_MSForm
            Case vbext_ct_ClassModule, vbext_ct_Document
            Case Else
                GoTo skip
            End Select

            If c.CodeModule.CountOfLines > 0 Then
                lcnt = c.CodeModule.CountOfLines
                cmCnt = 1
                cmdStr = ""

                If コード削除(c) Then
                    c.CodeModule.InsertLines 1, cmdStr
                    c.CodeModule.DeleteLines cmCnt, lcnt + 1
                End If
            End If
skip:
        Next
    End With

    MsgBox "トラップコード削除しました。"
End Sub

Private Function コード削除(ByRef cm)
    cd = cm.CodeModule.Lines(1, cm.CodeModule.CountOfLines)
    cdList = Split(cd, vbNewLine)

    '-- 挿入済み
    If Not cdList(0) = "'--Trap 挿入済み" Then
        コード削除 = False
        Exit Function
    End If

    For i = LBound(cdList) + 1 To UBound(cdList)
        If Not cdList(i) Like "*'--Trap" Then
            smdStrAdd cdList(i)
        End If
    Next

    コード削除 = True
End Function

Public Sub トラップコード挿入()
    Dim ext As String
    Dim c As Object

    If MsgBox(ActiveWorkbook.Name & vbNewLine & _
        "のトラップコード挿入", vbExclamation + vbOKCancel) = vbCancel Then
        Exit Sub
    End If

    Application.EnableEvents = False

    lno = 1

    With ActiveWorkbook.VBProject
        For Each c In .VBComponents
            Select Case c.Type
            Case vbext_ct_StdModule
            Case vbext_ct_MSForm
            Case vbext_ct_ClassModule, vbext_ct_Document
            Case Else
                GoTo skip
            End Select


            If c.CodeModule.CountOfLines > 0 Then
                lcnt = c.CodeModule.CountOfLines
                cmCnt = 1
                cmdStr = ""

                If コード挿入(c) Then
                    c.CodeModule.InsertLines 1, cmdStr
                    c.CodeModule.DeleteLines cmCnt, lcnt + 1
                End If
            End If
skip:
        Next
    End With

    MsgBox "トラップコード挿入しました。"

    Application.EnableEvents = True
End Sub

Private Function コード挿入(ByRef cm)
    cd = cm.CodeModule.Lines(1, cm.CodeModule.CountOfLines)
    cdList = Split(cd, vbNewLine)

    '-- 挿入済み
    If cdList(0) = "'--Trap 挿入済み" Or cdList(0) = "'--#Trap" Then
        コード挿入 = False
        Exit Function
    End If

    smdStrAdd "'--Trap 挿入済み"

    stFlag = False
    cFlag = False
    first = False


    For i = LBound(cdList) To UBound(cdList)
        Select Case True
        Case cdList(i) = "End Sub"
            smdStrAdd "    exit sub '--Trap"

            smdStrAdd "trap: '--Trap"
            smdStrAdd "    ErrTrap '--Trap"

            stFlag = False
            first = False

        Case cdList(i) = "End Function"
            smdStrAdd "    exit function '--Trap"

            smdStrAdd "trap: '--Trap"
            smdStrAdd "    ErrTrap '--Trap"

            stFlag = False
            first = False
        End Select

        cmd = Trim(cdList(i))

        Select Case True
        Case cmd Like "Select Case *"
        Case cmd Like "Case *"
        Case cmd Like "End Select"
        Case stFlag
            If cmd <> "" Then
                If Not cFlag Then
                    If Left(cmd, 1) <> "'" Then
                        smdStrAdd lno & " '--Trap"
                        lno = lno + 1
                    End If
                End If
            End If
        End Select

        smdStrAdd cdList(i)

        If Right(cmd, 1) = "_" Then
            cFlag = True
        Else
            cFlag = False
        End If

        Select Case True
        Case Left(cmd, 1) = "'"
        Case cmd Like "*Function * Lib *"

        Case cmd Like "*Sub *"
            stFlag = True
            first = True

        Case cmd Like "*Function *"
            If i > 1 Then
                If Not cdList(i - 1) = "'--#Trap" Then
                    stFlag = True
                    first = True
                End If
            End If
        End Select

        If first And stFlag And Not cFlag Then
            smdStrAdd "    on error goto trap '--Trap"
            first = False
        End If
skip:
    Next

    コード挿入 = True
End Function

モジュールを一括エクスポートする

出力先エクスポートファイルと比較して差分があるものだけ出力するので、Git管理に便利!
(https://gist.github.com/toagit/4561c2813bccf39aef0e2256822f3905 より引用)

'全モジュールエクスポート
'
'Excelの設定を以下の通りに変更すること
'1)オプション -> セキュリティーセンター -> [セキュリティーセンターの設定]ボタン押下
'2)マクロ設定(左ペイン) -> [VBAプロジェクトオブジェクトモデルへのアクセスを信頼する] チェックON

#If VBA7 And Win64 Then
    Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
                                                                  ByVal hwnd As Long, _
                                                                  ByVal pszPath As String, _
                                                                  ByVal psa As Long) As Long
#Else
    Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
                                                                  ByVal hwnd As Long, _
                                                                  ByVal pszPath As String, _
                                                                  ByVal psa As Long) As Long
#End If

Public Sub ExportAllModule()
    Dim destDir As String
    Dim rc As Long

    If MsgBox(ActiveWorkbook.Name & vbNewLine & "マクロを一括エクスポートします!", vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    End If

    destDir = ActiveWorkbook.Path & "\modules\" & ActiveWorkbook.Name

    rc = SHCreateDirectoryEx(0&, destDir, 0&)

    cnt = 0

    With ActiveWorkbook.VBProject
        Const vbext_ct_StdModule As Variant = 1
        Const vbext_ct_MSForm As Variant = 2
        Const vbext_ct_ClassModule As Variant = 3

        Dim ext As String
        Dim c As Object
        For Each c In .VBComponents
            Select Case c.Type
            Case vbext_ct_StdModule
                ext = ".bas"
            Case vbext_ct_MSForm
                ext = ".frm"
            Case vbext_ct_ClassModule, 100
                ext = ".cls"
            Case Else
                ext = Empty
            End Select

            If ext <> Empty Then
                cd = c.CodeModule.Lines(1, c.CodeModule.CountOfLines)
                fpath = destDir & "\" & c.Name & ext
                If 比較(cd, fpath) Then
                    Call c.Export(destDir & "\" & c.Name & ext)
                    cnt = cnt + 1
                End If
            End If

        Next

    End With

    MsgBox "モジュールのエクスポートを " & cnt & "件 完了しました。" & vbNewLine & destDir
End Sub

Function 比較(ByRef cd, fpath)
    比較 = True

    If Dir(fpath) = "" Then
        Exit Function
    End If

    Open fpath For Input As #1

    cdList = Split(cd, vbNewLine)

    i = 0
    begin = False

    Do Until EOF(1)
        Line Input #1, buf
        Select Case True
        Case Left(buf, 9) = "Attribute"
        Case Left(buf, 7) = "VERSION"
        Case UCase(Left(buf, 5)) = "BEGIN"
            begin = True
        Case buf = "END" And begin
            If begin Then
                begin = False
            End If
        Case begin
        Case Else
            If UBound(cdList) < i Then
                    GoTo stp
            End If
            If cdList(i) <> buf Then
                    GoTo stp
            End If
            i = i + 1
        End Select
    Loop

    比較 = False

stp:
    Close #1
End Function
J_Cotan
札幌在住ITコンサル(元NTT):【資格】システム監査、プロジェクトマネージャ、アプリケーションエンジニア、第1級陸上無線技術士、電気通信主任技術者、エコ検定、色彩検定(3級)、大型特殊(雪上車用)
http://cotan.jp
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away