Template_B02_TempTool

Option Explicit

'====================================================
'   セル文字を配列に格納
'====================================================
Sub SetAry()
    Dim i As Long
    Dim sttRow As Long        '開始行
    Dim midiRow As Long       '中間行
    Dim MaxRow As Long        '最終行
    Dim tgtCol As Long        '対象列
    Dim lmtNo As Long         '対象列
    Dim buf As String
    Dim temp As String
    Dim myStr As String
    
    Dim buf2 As String
    Dim temp2 As String
    Dim myStr2 As String

    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination

    Bln_Err = False
    nmlTmn = False
    ErrProsName = "SeｔAry"
    On Error GoTo SetAry_Err

    Call StopUpdating

    IsCall = False     '初期値
    
    With ActiveSheet

        sttRow = 2
        tgtCol = 3        '切り替えて使用
        lmtNo = 52

'        tgtCol = 15      '切り替えて使用
'        lmtNo = 65
        
        'A列基準最終行取得
        MaxRow = .Cells(Rows.Count, tgtCol).End(xlUp).Row

        temp = "abcdefghijArray("
        For i = sttRow To MaxRow
           
            buf = Trim(.Cells(i, tgtCol).Value)
            buf = """" & buf & """, "
            
            If i = MaxRow Then
                myStr = myStr & temp & buf
            ElseIf Len(temp) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = ""
                temp = temp & buf
            End If
            .Cells(i, tgtCol + 2).Value = .Cells(i, tgtCol + 1).Interior.Color
        Next i
        
        'ダブルクォーテーションなし　　     '切り替えて使用
'        myStr = Replace(myStr, """", "")
        Debug.Print Left(myStr, InStrRev(myStr, ",") - 1) & ")"
'==============================================================================
'        '色番号取得　　     '切り替えて使用
'        temp2 = "ABCDEFGHIJArray("
'        For i = sttRow To MaxRow
'            buf2 = .Cells(i, tgtCol + 1).Interior.Color
'            .Cells(i, tgtCol + 2).Value = buf2
'
'            buf2 = buf2 & ", "
'
'            If i = MaxRow Then
'                myStr2 = myStr2 & temp2 & buf2
'            ElseIf Len(temp2) <= lmtNo Then
'                temp2 = temp2 & buf2
'            Else
'                myStr2 = myStr2 & temp2 & " _" & vbCrLf
'                temp2 = ""
'                temp2 = temp2 & buf2
'            End If
'
'        Next i

'        'ダブルクォーテーションなし　　     '切り替えて使用
''        myStr = Replace(myStr, """", "")
'        Debug.Print Left(myStr2, InStrRev(myStr2, ",") - 1) & ")"
'==============================================================================
    End With

SetAry_Exit:

    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    
Exit Sub

SetAry_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear          'エラー情報クリア
    GoTo SetAry_Exit
End Sub

'====================================================
'   セル文字を配列に格納　2分割Ver.
'====================================================
Sub SetAry2()
    Dim i As Long
    Dim sttRow As Long        '開始行
    Dim midiRow As Long       '中間行
    Dim MaxRow As Long        '最終行
    Dim tgtCol As Long        '対象列
    Dim lmtNo As Long         '対象列
    Dim buf As String
    Dim temp As String
    Dim myStr As String

    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination

    Bln_Err = False
    nmlTmn = False
    ErrProsName = "SetAry2"
    On Error GoTo SetAry2_Err

    Call StopUpdating

    IsCall = False     '初期値
    
    With ActiveSheet

        sttRow = 13
        tgtCol = 5
        lmtNo = 52
        
'        tgtCol = 15 　　     '切り替えて使用
'        lmtNo = 65
        
        'A列基準最終行取得
        MaxRow = .Cells(Rows.Count, tgtCol).End(xlUp).Row
        midiRow = Int((MaxRow - sttRow) / 2) + 1

        temp = "abcdefghijArray("
        For i = sttRow To midiRow
            buf = Trim(.Cells(i, tgtCol).Value)
            buf = """" & buf & """, "
'            buf = buf & """, "  　　     '切り替えて使用
            If i = midiRow Then
                myStr = myStr & temp & buf
            ElseIf Len(temp) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = ""
                temp = temp & buf
            End If
        Next i
        'ダブルクォーテーションなし　　     '切り替えて使用
'        myStr = Replace(myStr, """", "")
        Debug.Print Left(myStr, InStrRev(myStr, ",") - 1) & ")"
        myStr = ""      '初期化
        temp = "ABCDEFGHIJArray("
        For i = midiRow + 1 To MaxRow
            buf = .Cells(i, tgtCol).Value
            buf = """" & buf & """, "
            
            If i = MaxRow Then
                myStr = myStr & temp & buf
            ElseIf Len(temp) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = ""
                temp = temp & buf
            End If
        Next i
        
        temp = temp & buf
        'ダブルクォーテーションなし　　     '切り替えて使用
'        myStr = Replace(myStr, """", "")
        Debug.Print Left(myStr, InStrRev(myStr, ",") - 1) & ")"
    
    End With

SetAry2_Exit:

    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    
Exit Sub

SetAry2_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear          'エラー情報クリア
    GoTo SetAry2_Exit
    
End Sub

'====================================================
'   行高取得
'====================================================
Sub getRowHeight()
    
    Dim i As Long
    Dim MaxRow As Long
    Dim tgtCol As Long
    Dim buf As String
    Dim strAry As String

    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination
    Bln_Err = False
    nmlTmn = False
    ErrProsName = "getRowHeight"
    On Error GoTo getRowHeight_Err

    Call StopUpdating

    IsCall = False     '初期値
    
    With ActiveSheet
    
        tgtCol = 2
        'tgtCol基準最終行取得
        MaxRow = .Cells(Rows.Count, tgtCol).End(xlUp).Row

        For i = 1 To MaxRow
            buf = .Cells(i, tgtCol).RowHeight & ","
            strAry = strAry & buf
        Next i

    End With
    
    Debug.Print Left(strAry, InStrRev(strAry, ",") - 1)

getRowHeight_Exit:

    'エラーを無視
    On Error Resume Next

    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    
Exit Sub

getRowHeight_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear          'エラー情報クリア
    GoTo getRowHeight_Exit
    
End Sub

'====================================================
'   列幅取得
'====================================================
Sub getColWidth()
    
    Dim j As Long
    Dim MaxCol As Long
    Dim tgtRow As Long
    Dim buf As String
    Dim strAry As String

    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination
    
    Bln_Err = False
    nmlTmn = False
    
    ErrProsName = "getColWidth"
    
    On Error GoTo getColWidth_Err

    Call StopUpdating

    IsCall = False     '初期値
    
    With ActiveSheet
        tgtRow = 9
        'tgtRow基準最終列取得
        MaxCol = .Cells(tgtRow, Columns.Count).End(xlToLeft).Column

        For j = 1 To MaxCol
            buf = .Cells(tgtRow, j).ColumnWidth & ","
            strAry = strAry & buf
        Next j

    End With
    
    Debug.Print Left(strAry, InStrRev(strAry, ",") - 1)

getColWidth_Exit:

    'エラーを無視
    On Error Resume Next

    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    
Exit Sub

getColWidth_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear          'エラー情報クリア
    GoTo getColWidth_Exit
    
End Sub