DA

'DA                ・・・元場所：IkiAddin.ModAlignmentCode
'GetClipText       ・・・元場所：IkiAddin.ModClipboard
'Split_Start1      ・・・元場所：IkiAddin.ModArray
'ConvArray1D_Start1・・・元場所：IkiAddin.ModArray
'CheckArray1D      ・・・元場所：IkiAddin.ModArray
'DeleteRowArray1D  ・・・元場所：IkiAddin.ModArray
'CheckArray1DStart1・・・元場所：IkiAddin.ModArray
'DeleteDoubleSpace ・・・元場所：IkiAddin.ModStr
'ClipText          ・・・元場所：IkiAddin.ModClipboard
'ShowCodeWindow    ・・・元場所：IkiAddin.ModAlignmentCode

Public Sub DA()
'変数定義の一覧から、値格納の式を追加する
'Dim ** As **の[D][A]を取ってDA
'20240202

'Dim Value AS String
'↓
'Dim Value As String: Value =

'Dim Sheet AS WorkSheet
'↓
'Dim Sheet AS WorkSheet: Set Sheet =

    '情報取得
    Dim Text     As String: Text = GetClipText
    If Text = "" Then Exit Sub
    Dim TextList As Variant: TextList = Split_Start1(Text, vbCrLf)
    
    '最後の値が空白なら除外する
    Dim N As Long: N = UBound(TextList, 1)
    If TextList(N) = "" Then
        If N = 1 Then
            Exit Sub
        Else
            TextList = DeleteRowArray1D(TextList, N)
            N = N - 1
        End If
    End If
    
    '変数に当たる型を一覧で取得しておく
    Dim Dict_Value As New Dictionary
    Dict_Value.Add "Long", ""
    Dict_Value.Add "String", ""
    Dict_Value.Add "Integer", ""
    Dict_Value.Add "Double", ""
    Dict_Value.Add "Date", ""
    Dict_Value.Add "Variant", ""
    
    '各行で処理
    Dim I                     As Long
    Dim Output                As Variant: ReDim Output(1 To N)
    Dim Str                   As String
    Dim Str_DeleteDoubleSpace As String
    Dim TmpSplit              As Variant
    Dim ValueName             As String
    Dim Variable_             As String
    Dim AddStr                As String
    For I = 1 To N
        Str = TextList(I)
        Str_DeleteDoubleSpace = DeleteDoubleSpace(Str) '連続する半角スペースを消去
        Str_DeleteDoubleSpace = LTrim(Str_DeleteDoubleSpace) 'インデントを消去
        AddStr = ""
        If Str_DeleteDoubleSpace Like "Dim * As *" Then
            TmpSplit = Split_Start1(Str_DeleteDoubleSpace, " ")
            If UBound(TmpSplit, 1) = 4 Then
                ValueName = TmpSplit(2)
                Variable_ = TmpSplit(4)
                If Dict_Value.Exists(Variable_) = True Then
                    AddStr = ": " & ValueName & " ="
                Else
                    AddStr = ": Set " & ValueName & " ="
                End If
            End If
        End If
        Output(I) = Str & AddStr
    Next
    
    'クリップボード格納
    Call ClipText(Output)
    
    'コードウィンドウ表示
    Call ShowCodeWindow
    
End Sub

Private Function GetClipText() As String
'クリップボードに格納中の文字列データを取得する
'「Microsoft Forms 2.0 Object Library」ライブラリを参照すること
'参考：http://officetanaka.net/excel/vba/tips/tips20.htm
'20240105
    
    '処理
    'クリップボードに格納されているのが画像以外の場合のエラー回避
    On Error Resume Next
    Dim Output As String
    Dim Clip   As New DataObject
    With Clip
        .GetFromClipboard
        Output = .GetText
    End With
    On Error GoTo 0
    
    '出力
    GetClipText = Output

End Function

Private Function Split_Start1(ByRef Expression As String, _
                              ByRef Delimiter As String) _
                                              As Variant
'Split関数の代替
'Delimiter(区切り文字)が存在しない場合は、要素1の一次元配列として返す
'返す一次元配列の開始要素番号は1とする
'20221020
'20221104 修正
'紹介予定

'引数
'Expression・・・文字列
'Delimiter ・・・区切り文字
    
    '処理
    Dim Output As Variant
    If InStr(Expression, Delimiter) = 0 Then '文字列の中に区切り文字が存在しない場合
        ReDim Output(1 To 1)
        Output(1) = Expression
    Else '存在する場合
        Output = Split(Expression, Delimiter)
'        Output = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Output))
        Output = ConvArray1D_Start1(Output) '20221104
    End If
    
    '出力
    Split_Start1 = Output

End Function

Private Function ConvArray1D_Start1(Array1D As Variant) As Variant
'開始要素番号が0の一次元配列を開始要素番号1に変換する
'20221027
    
    '引数チェック
    Call CheckArray1D(Array1D)
    If LBound(Array1D, 1) = 1 Then
'        MsgBox "開始要素番号が1なので変換の必要はありません", vbExclamation
        ConvArray1D_Start1 = Array1D
        Exit Function
    End If
    
    '処理
    Dim N      As Long:    N = UBound(Array1D, 1)
    Dim Output As Variant: ReDim Output(1 To N + 1)
    Dim I      As Long
    For I = 1 To N + 1
        If IsObject(Array1D(I - 1)) = True Then
            Set Output(I) = Array1D(I - 1)
        Else
            Output(I) = Array1D(I - 1)
        End If
    Next
    
    '出力
    ConvArray1D_Start1 = Output
    
End Function

Private Sub CheckArray1D(ByRef Array1D As Variant, _
             Optional ByRef ArrayName As String = "Array1D")
'入力配列が一次元配列かどうかチェックする
'20210804
'20220309 変数名変更

'引数
'Array1D    ・・・チェックする配列
'[ArrayName]・・・エラーメッセージで表示する時の名前

    On Error Resume Next
    Dim Dummy As Long: Dummy = UBound(Array1D, 2)
    On Error GoTo 0
    If Dummy <> 0 Then
        MsgBox ArrayName & "は一次元配列を入力してください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Function DeleteRowArray1D(ByRef Array1D As Variant, _
                               ByRef DeleteRow As Long) _
                                               As Variant
'一次元配列の指定行を消去した配列を出力する
'20220203
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/32349060.html

'引数
'Array1D  ・・・一次元配列
'DeleteRow・・・消去する行番号

'返り値
'指定行が消去された一次元配列

    '引数チェック
    Call CheckArray1D(Array1D)       '一次元配列かチェック
    Call CheckArray1DStart1(Array1D) '開始要素番号が1かチェック
    
    Dim N As Long: N = UBound(Array1D, 1) '行数
    
    If DeleteRow < 1 Then
        MsgBox ("削除する行番号は1以上の値を入れてください")
        Stop
        Exit Function
    ElseIf DeleteRow > N Then
        MsgBox ("削除する行番号は元の一次元配列の行数" & N & "以下の値を入れてください")
        Stop
        Exit Function
    End If
    
    '処理
    Dim I      As Long
    Dim J      As Long
    Dim K      As Long
    Dim Output As Variant: ReDim Output(1 To N - 1)
    K = 0
    For I = 1 To N
        If I <> DeleteRow Then
            K = K + 1
            Output(K) = Array1D(I)
        End If
    Next I
    
    '出力
    DeleteRowArray1D = Output

End Function

Private Sub CheckArray1DStart1(ByRef Array1D As Variant, _
                   Optional ByRef ArrayName As String = "Array1D")
'入力一次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更

'引数
'Array1D    ・・・チェックする一次元配列
'[ArrayName]・・・エラーメッセージで表示する時の名前
    
    If LBound(Array1D, 1) <> 1 Then
        MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Function DeleteDoubleSpace(ByVal Str As String) As String
'20211019
'文字列の連続半角スペースを消去する
    Dim Str2 As String
    
    If InStr(1, Str, "  ") = 0 Then
        Str2 = Str
        GoTo EndEscape
    End If
    
    Str2 = Replace(Str, "  ", " ")
    Do
        Str = Str2
        Str2 = Replace(Str, "  ", " ")
        If Str = Str2 Then
            Exit Do
        End If
    Loop

EndEscape:
    DeleteDoubleSpace = Str2

End Function

Private Sub ClipText(ByVal Text As Variant)
'テキストをクリップボードに格納
'テキストが配列ならば列方向をTab区切り、行方向を改行

'引数
'Text・・・クリップボードに格納するテキスト
'          文字列、一次元配列、二次元配列に対応
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '引数処理
    '入力した引数が文字列、一次元配列、二次元配列のどれかを判定
    Dim Dimension  As Long
    Dim Dummy      As Long
    If IsArray(Text) = False Then '配列でない場合
        Dimension = 0
    Else '配列の場合
        On Error Resume Next
        Dummy = UBound(Text, 2)
        On Error GoTo 0
        If Dummy = 0 Then
            Dimension = 1 '一次元配列と判定
        Else
            Dimension = 2 '二次元配列と判定
        End If
    End If
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '処理
    'クリップボードに格納用のテキスト変数を作成
    Dim Output As String
    Dim I      As Long
    Dim J      As Long
    
    If Dimension = 0 Then
        '文字列の場合
        Output = Text
        
    ElseIf Dimension = 1 Then
        '一次元配列の場合
        Output = ""
        For I = LBound(Text, 1) To UBound(Text, 1)
            If I = LBound(Text, 1) Then
                Output = Text(I)
            Else
                Output = Output & vbCrLf & Text(I)
            End If
        Next I
        
    ElseIf Dimension = 2 Then
        '二次元配列の場合
        Output = ""
        For I = LBound(Text, 1) To UBound(Text, 1)
            For J = LBound(Text, 2) To UBound(Text, 2)
                If J < UBound(Text, 2) Then
                    '列方向Tab区切り
                    Output = Output & Text(I, J) & Chr(9)
                Else
                    Output = Output & Text(I, J)
                End If
            Next J
            
            If I < UBound(Text, 1) Then
                '行方向を改行
                Output = Output & vbCrLf
            End If
        Next I
    End If
    
    'クリップボードに格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Output
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
    
End Sub

Private Sub ShowCodeWindow()
'表示中のコードウィンドウをフォーカスする。
'20211223
'20211227修正
    
    Dim WSH As Object: Set WSH = CreateObject("WScript.Shell")
    Call WSH.SendKeys("{F7}")
End Sub