https://www.limecode.jp/entry/fungo/068-export-all-textboxes-in-form-to-worksheet

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：全テキストボックスの転記

#VBA100本ノック 68本目
フォームの「登録」ボタンをクリックしたら、全てのTextBoxの値をアクティブシートに出力した後にフォームを閉じてください。
シート出力位置
・データ最終行のすぐ下の行
・シートの1行目にあるコントロール名で探した列
・列が見つからない場合は、右端に追加してください
・改行は全て削除する

ユーザーフォームサンプル

◇ 出題ページはこちら

ソースコード

標準モジュール

Option Explicit

Sub UserForm1を表示する()

    UserForm1.Show vbModeless

End Sub

Formモジュール

Option Explicit

' 100本ノック068本目：全テキストボックスの転記
Private Sub btn登録_Click()

    ' 出力行の取得
    Dim ws出力 As Worksheet: Set ws出力 = ActiveSheet
    Dim R_出力 As Long: R_出力 = Get最終行(ws出力) + 1
    
    ' 全コントロールのうちTextBoxをループ
    Dim コントロール As Control
    For Each コントロール In Me.Controls
        If TypeName(コントロール) = "TextBox" Then
            
            ' 出力列を検索
            Dim C_出力 As Long
            C_出力 = Match列番号(コントロール.Name, ws出力.Rows(1))
            
            ' なければ列を追加
            If C_出力 = 0 Then
                C_出力 = Get最終列(ws出力) + 1
                ws出力.Cells(1, C_出力) = コントロール.Name
            End If
            
            ' 値を出力
            ws出力.Cells(R_出力, C_出力).Value _
                = 文中改行を指定文字に置き換える(コントロール.Value, "")
            
        End If
    Next ' 全コントロールのうちTextBoxをループ

    Unload Me

End Sub

汎用関数モジュール

Option Explicit

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 列番号の検索
' ◆ ブログ未掲載
Function Match列番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Match列番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Column - 1
    Else
        Match列番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Column - 1
    End If
End Function

' 改行文字の置き換え
' 参考：https://www.limecode.jp/entry/syntax/linebreak-vbcrlf-vbcr-vblf
Function 文中改行を指定文字に置き換える(元テキスト As String, Optional 置換テキスト As String = " ") As String

    Dim 結果テキスト As String
    結果テキスト = Replace(元テキスト, vbCrLf, 置換テキスト)
    結果テキスト = Replace(結果テキスト, vbCr, 置換テキスト)
    結果テキスト = Replace(結果テキスト, vbLf, 置換テキスト)

    文中改行を指定文字に置き換える = 結果テキスト

End Function