S08_結合範囲貼付

'S08_結合範囲貼付       ・・・元場所：VBAProject.Mod08_結合範囲貼り付け
'GetClipText            ・・・元場所：VBAProject.Mod99_アドインから
'ConvCellCopyTextToArray・・・元場所：VBAProject.Mod91_一次作業用
'Split_Start1           ・・・元場所：VBAProject.Mod99_アドインから
'ConvArray1D_Start1     ・・・元場所：VBAProject.Mod99_アドインから
'IsArray1D              ・・・元場所：VBAProject.Mod99_アドインから
'GetSelectionCell       ・・・元場所：VBAProject.Mod99_アドインから
'OffsetCell             ・・・元場所：VBAProject.Mod99_アドインから



Public Sub S08_結合範囲貼付()
    
    'クリップボードからテキスト取得
    Dim Text As String: Text = GetClipText
    If Text = "" Then Exit Sub
    
    'クリップボードのテキストを配列に変換
    Dim Output As Variant: Output = ConvCellCopyTextToArray(Text)
    
    '選択セル取得
    Dim SelectCell As Range: Set SelectCell = GetSelectionCell
    If SelectCell Is Nothing Then Exit Sub
    
    '貼り付け
    Dim I As Long
    Dim J As Long
    Dim N As Long: N = UBound(Output, 1)
    Dim M As Long: M = UBound(Output, 2)
    For I = 1 To N
        For J = 1 To M
            OffsetCell(SelectCell, I - 1, J - 1).Value = Output(I, J)
        Next
    Next

End Sub

Private Function GetClipText() As String
'クリップボードに格納中の文字列データを取得する
'参考：http://officetanaka.net/excel/vba/tips/tips20.htm
'「Microsoft Forms 2.0 Object Library」ライブラリを参照すること
'20240105
'https://www.softex-celware.com/post/getcliptext
    
    '処理
    'クリップボードに格納されているのが画像以外の場合のエラー回避
    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 ConvCellCopyTextToArray(Text As String) As Variant
'結合範囲を含んだセル範囲をコピーしてクリップボードに格納されたテキストを、セルの配置用の配列に変換する
'20260316
    
    '一番後ろの改行を消去する
    If Right(Text, 2) = vbCrLf Then
        Text = Mid(Text, 1, Len(Text) - 2)
    End If
    
    Dim ListSplitCrLf As Variant: ListSplitCrLf = Split_Start1(Text, vbCrLf)
                                                                            
    Dim StrSplitCrLf  As String
    Dim I             As Long
    Dim N             As Long: N = UBound(ListSplitCrLf, 1)
    Dim Output        As Variant
    Dim TmpSplit      As Variant
    Dim M             As Long
    Dim J             As Long
    For I = 1 To N
        StrSplitCrLf = ListSplitCrLf(I)
        TmpSplit = Split_Start1(StrSplitCrLf, Chr(9))
        
        If I = 1 Then
            M = UBound(TmpSplit, 1)
            ReDim Output(1 To N, 1 To M)
        End If
        
        For J = 1 To M
            Output(I, J) = TmpSplit(J)
        Next
    Next
        
    ConvCellCopyTextToArray = Output
        
End Function

Private Function Split_Start1(ByRef Expression As String, _
                              ByRef Delimiter As String, _
                      Optional ByRef MaxCount As Long = 0) _
                                              As Variant
'Split関数の代替
'Delimiter(区切り文字)が存在しない場合は、要素1の一次元配列として返す
'返す一次元配列の開始要素番号は1とする
'20221020
'20221104 修正
'20250829 再々要素数MaxCountを指定可能に
'https://www.softex-celware.com/post/splitstart1

'引数
'Expression・・・文字列
'Delimiter ・・・区切り文字
'[MaxCount]・・・最大要素数

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

End Function

Private Function ConvArray1D_Start1(Array1D As Variant) As Variant
'開始要素番号が0の一次元配列を開始要素番号1に変換する
'20221027
'https://www.softex-celware.com/post/convarray1d_start1
    
    '引数チェック
    If IsArray1D(Array1D) = False Then Exit Function
    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 Function IsArray1D(ByRef Array1D As Variant, _
               Optional ByRef ArrayName As String = "Array1D") _
                                        As Boolean
'入力配列が一次元配列かどうかチェックする
'20210804
'20220309 変数名変更
'20241230 Functionプロシージャにして判定結果を返す
'https://www.softex-celware.com/post/isarray1d

'引数
'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 Function 'Falseが返ってくる
    End If

    '出力
    IsArray1D = True
    
End Function

Private Function GetSelectionCell() As Range
'選択中のセルを取得する
'セル以外を選択している場合はNothingを返す
'20220312
'https://www.softex-celware.com/post/getselectioncell
    
    '処理
    Dim Dummy  As Object: Set Dummy = Selection
    Dim Output As Range: Set Output = Nothing
    If TypeName(Dummy) = "Range" Then
        Set Output = Dummy
    End If
    
    '出力
    Set GetSelectionCell = Output
End Function

Private Function OffsetCell(ByRef Cell As Range, _
             Optional ByRef RowOffset As Long = 0, _
             Optional ByRef ColOffset As Long = 0) _
                                      As Range
'Range.Offsetプロパティの直感に反する処理を解消
'セル結合の影響を排除する
'20230127
'https://www.softex-celware.com/post/offsetcell
    
'引数
'Cell       ・・・基準セル
'[RowOffset]・・・下方向のオフセット量
'[ColOffset]・・・右方向のオフセット量
    
    If Cell Is Nothing Then Exit Function
    
    '処理
    Dim Sheet  As Worksheet: Set Sheet = Cell.Worksheet
    
    Dim Output As Range
    Set Output = Sheet.Cells(Cell.Row + RowOffset, _
                             Cell.Column + ColOffset)
    
    '出力
    Set OffsetCell = Output
    
End Function