ヘッダー行から変数作成　① クリップボードに格納 - Infomentのブログ～Excel VBA奮闘記～

例えばいつもの、「なんちゃって個人情報」。
f:id:Infoment:20201031221523p:plain

このヘッダー行を使って、そのまま変数にすることがある。
f:id:Infoment:20201031221812p:plain

或いは、列挙体を作成することもある。
f:id:Infoment:20201031221901p:plain

先日この作業をしていて、唐突に、とても面倒くさくなった。
よし、自動化に挑戦してみよう。
f:id:Infoment:20201031222200p:plain

今回の作戦は、こんな感じだ。

表のヘッダー行、または全体を選択する。
選択したもののうち、一行目をユーザーフォームに表示する。
表示した内容を、クリップボードに格納する。

クリップボードに格納してしまえば、あとはどこにでも貼り付けられる。

ユーザーフォーム（EditVariableForm）

ユーザーフォームのデザインとしては、こんな感じかな。
f:id:Infoment:20201031223115p:plain

オブジェクト名は、それぞれ以下とした。

リストボックス　⇒　ItemListBox
コマンドボタン　⇒　CopyButton

都合が悪くなったら、後で変更しよう。

さて、まず選択範囲について、一行目をリスト用配列として取得する必要がある。選択範囲に対して常に一定に戻り値となるのだから、今回はPropertyで受けることにした。

ところで、同じ適用範囲内で、同じ名前の変数は宣言できない。
f:id:Infoment:20201031223753p:plain

一方で多くの表では、テーブルとして書式設定されている場合を除き、ラベル名称が同じものをよく見かける。これでは、そのまま変数名に適用すると重複を理由にエラーが発生してしまう。

そこで変数名が重複する場合は、その後ろに連番を付すことで、エラーを回避することとした。

' 選択範囲からラベル行を取得して配列化。
Private Property Get HeaderList() As Variant
        
    ' 一列しかないなら、このツールは使わなくてもＯＫ。
        If Selection.Columns.Count = 1 Then
            HeaderList = Array()
            Exit Property
        End If
    
    ' 表全体を選択されているかもしれないので、
    ' 一行目だけ配列に入れたうえで縦横入れ替え。
    Dim arr As Variant
        arr = Selection.Rows(1)
        arr = WorksheetFunction.Transpose(arr)
    
    ' 変数名などは重複が許されないため、辞書で重複確認。
    ' 重複した場合、後ろに数字を付す（重複毎カウントアップ）。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim i As Long
        For i = 1 To UBound(arr)
            If Not Dict.Exists(arr(i, 1)) Then
                Dict(arr(i, 1)) = 1
            Else
                Dict(arr(i, 1)) = Dict(arr(i, 1)) + 1
                Dict(arr(i, 1) & Dict(arr(i, 1))) = 1
            End If
        Next
        HeaderList = WorksheetFunction.Transpose(Dict.Keys)
End Property

上記を利用してユーザーフォーム起動時に、リストに項目をセットした。

Private Sub UserForm_Initialize()

    ' 選択範囲が１列の場合、このツールを使用する条件不成立とする。
    If UBound(HeaderList) = -1 Then Exit Sub
    
    ' 選択範囲のヘッダー部をリスト表示。
    ItemListBox.List = HeaderList
    
End Sub

今回は重複エラー回避確認のため、同じ列をコピー・配置してみた。
f:id:Infoment:20201031224402p:plain

↓ ここまでは、取り敢えずＯＫか。
f:id:Infoment:20201031224524p:plain

次いで、クリップボードにコピーする部分を作成。

Private Property Get CopyText() As String
    Dim arr As Variant
        
        ' この時点で、複数行１列の二次元配列。
        arr = ItemListBox.List
        
        ' 縦横入れ替えで、一次元配列に変換。
        arr = WorksheetFunction.Transpose(arr)
        
        CopyText = Join(arr, vbNewLine)
End Property

' 作成結果をクリップボードにコピー。
Private Sub CopyButton_Click()
        With CreateObject("Forms.TextBox.1")
            .MultiLine = True
            .Text = CopyText
            .SelStart = 0
            .SelLength = .TextLength
            .Copy
        End With
End Sub