メモ

1次元データを2次元データへ並び替える

Option Explicit

' *****************************************************
' 説明
'  1列(1次元)データを〇×〇(2次元)データへ並び替える為のモジュール

' 使い方
' 　設定で下記を設定し、Executeを実行する
'    ・シート名
'    ・生成データのMAX行数(createRow)
' *****************************************************

' 設定
Private Const settingsSh As String = "入力"    ' 入力シート
Private Const outputSh As String = "出力"     ' 出力シート
Private Const createRow As Integer = 12       ' 出力データ最終行
Private Const direction As String = "Left"          ' 出力データ生成開始方向 (Right or Left)

' *****************************************************
' 実行ボタン
' *****************************************************
Sub Execute()
    Dim settingsWs As Worksheet
    Dim outputWs As Worksheet
    Dim readCol As Long               ' 読み取り列
    Dim maxRngRow As Integer    ' 出力データの最終行
    Dim sourceData As Variant       ' 読み取りデータ
    Dim outputData As Variant       ' 出力データ
    Dim settingsLastCol As Long
        
    ' シート取得
    Set settingsWs = ThisWorkbook.Sheets(settingsSh)
    Set outputWs = ThisWorkbook.Sheets(outputSh)
    
    ' 出力シートクリア
    Call outputWs.Cells.ClearContents
    
    ' 設定シートから生成データ行数を取得
    maxRngRow = createRow
    
    ' 最終列取得
    settingsLastCol = settingsWs.Cells(1, settingsWs.Columns.Count).End(xlToLeft).Column
    
    Dim i As Long
    For i = 1 To settingsLastCol
        ' 並び替えを行うデータを取得
        readCol = i     ' 読み取りデータ取得列
        sourceData = ReadSettings(settingsWs, readCol)
        
        ' 出力データ作成
        outputData = createData(maxRngRow, sourceData)
        
        Call output(outputWs, outputData)
    Next i
End Sub

' *****************************************************
' データ読込関数(1列データ取得)
' *****************************************************
Function ReadSettings(ws As Worksheet, readCol As Long)
    Dim lastRow As Long
    Dim columnAddress As String
    Dim dataRange As Range
    Dim DataArray As Variant
    Dim maxArrayNum As Long
    Dim reverseDataArray As Variant
    Dim outputWs As Worksheet
    
    ' 列アドレスを取得
    columnAddress = Split(Cells(1, readCol).Address, "$")(1)
    
    lastRow = ws.Cells(ws.Rows.Count, readCol).End(xlUp).Row
    
    ' 指定列のデータ範囲を取得
    Set dataRange = ws.Range(columnAddress & "1:" & columnAddress & lastRow)
    
    ' データ範囲を1次元配列に変換
    DataArray = Application.Transpose(dataRange.Value)
    
'    ' dataArrayを順番を逆にする
'    maxArrayNum = UBound(DataArray)
'    ReDim reverseDataArray(1 To maxArrayNum)
'    Dim i As Long
'    For i = 0 To UBound(DataArray)
'        If maxArrayNum <> i Then
'            reverseDataArray(maxArrayNum - i) = DataArray(i + 1)
'        End If
'    Next i
    
    ReadSettings = DataArray
End Function

' *****************************************************
' 出力データ作成関数
' *****************************************************
Function createData(maxRngRow As Integer, DataArray As Variant) As Variant
    Dim maxRngCol As Integer        ' 出力データの最終列
    Dim outputData As Variant        ' 生成データ
    Dim copyData As Variant
    Dim outputCount As Integer
    
    ' 生成データの最終列を算出
    maxRngCol = UBound(DataArray) / maxRngRow
    
    If maxRngCol * maxRngRow < UBound(DataArray) Then
        maxRngCol = maxRngCol + 1
    End If
    
    ' 初期化
    ReDim outputData(1 To maxRngCol, 1 To maxRngRow)
    outputCount = 0
    
    Dim i As Integer
    Dim j As Integer
    For i = 1 To maxRngRow
        For j = 1 To maxRngCol
            If outputCount < UBound(DataArray) Then
                outputCount = outputCount + 1
                outputData(j, i) = DataArray(outputCount)
            Else
                outputData(j, i) = ""
            End If
        Next j
    Next i
    
    If direction = "Left" Then
        ' 列を逆順にコピー
        Dim reversedArray As Variant
        Dim k As Integer
        
        ReDim reversedArray(1 To maxRngCol, 1 To maxRngRow)
        k = 1
        For j = UBound(outputData, 2) To LBound(outputData, 2) Step -1
            For i = LBound(outputData, 1) To UBound(outputData, 1)
                reversedArray(i, k) = outputData(i, j)
            Next i
            k = k + 1
        Next j
        
        createData = reversedArray
    Else
        createData = outputData
    End If
End Function

' *****************************************************
' 出力処理
' *****************************************************
Sub output(outputWs As Worksheet, outputData As Variant)
    Dim startCell As Range
    Dim outputCol As Long
    
    ' 出力位置列番号取得
    outputCol = outputWs.Cells(1, outputWs.Columns.Count).End(xlToLeft).Column
    If outputCol <> 1 Then
        outputCol = outputCol + 2
    End If
    ' 出力開始位置セル取得
    Set startCell = outputWs.Cells(1, outputCol)
    ' 出力
    startCell.Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
End Sub

2次元データを1次元データへ並び替える

Option Explicit

' *****************************************************
' 説明
'  〇×〇データ(2次元)を1列(1次元)データへ並び替える為のモジュール

' 使い方
' 　設定で下記を設定し、Convert2DArrayTo1Dを実行する
'    ・シート名
'    ・出力方向
' *****************************************************

' 設定
Private Const settingsSh As String = "入力"    ' 入力シート
Private Const outputSh As String = "出力"     ' 出力シート
Private Const direction As String = "Left"     ' データ読み取り開始方向 (Right or Left)

' *****************************************************
' 実行ボタン
' *****************************************************
Sub Convert2DArrayTo1D()
    Dim settingsWs As Worksheet
    Dim outputWs As Worksheet
    Dim startCell As Range
    Dim dataRange As Range
    Dim DataArray As Variant
    Dim outputArray() As Variant
    Dim i As Long, j As Long
    Dim outputIndex As Long
    Dim settingsLaststartCol As Long
    Dim outputCount As Integer
    Dim startCol As Long

    ' シートを設定
    Set settingsWs = ThisWorkbook.Sheets(settingsSh)
    Set outputWs = ThisWorkbook.Sheets(outputSh)
    ' 出力シートクリア
    Call outputWs.Cells.ClearContents
    
    ' 最終列取得
    settingsLaststartCol = settingsWs.Cells(1, settingsWs.Columns.Count).End(xlToLeft).End(xlToLeft).Column
    outputCount = 1
    startCol = 1
    While startCol < settingsLaststartCol - 1
        
        If outputCount <> 1 Then
            startCol = settingsWs.Cells(1, startCol).End(xlToRight).End(xlToRight).Column
        End If
        
        ' 読み取り開始列
        Set startCell = settingsWs.Cells(1, startCol)
        
        ' データ範囲を設定
        Set dataRange = startCell.CurrentRegion
        DataArray = dataRange.Value ' 2次元配列として読み込む

        If direction = "Left" Then
            outputArray = createDataLeft(DataArray)
        Else
            outputArray = createDataRight(DataArray)
        End If

        ' 結果をシートに出力
        outputWs.Cells(1, outputCount).Resize(UBound(outputArray), 1).Value = Application.Transpose(outputArray)
        outputCount = outputCount + 1
    Wend
    
    MsgBox "データの結合が完了しました。", vbInformation
End Sub

' *****************************************************
' 出力データ作成(読み取り方向：左)
' *****************************************************
Function createDataLeft(DataArray As Variant)
    Dim outputArray As Variant
    Dim i As Integer
    Dim j As Integer
    Dim outputIndex As Integer
    
    ' 出力配列のサイズを決定
    ReDim outputArray(1 To UBound(DataArray, 1) * UBound(DataArray, 2))

    ' 2次元配列を1次元配列に変換
    outputIndex = 1
    For j = UBound(DataArray, 2) To LBound(DataArray, 2) Step -1
        For i = LBound(DataArray, 1) To UBound(DataArray, 1)
            If Not IsEmpty(DataArray(i, j)) Then
                outputArray(outputIndex) = DataArray(i, j)
            End If
            outputIndex = outputIndex + 1
        Next i
    Next j
    
    createDataLeft = outputArray
End Function

' *****************************************************
' 出力データ作成(読み取り方向：右)
' *****************************************************
Function createDataRight(DataArray As Variant)
    Dim outputArray As Variant
    Dim i As Integer
    Dim j As Integer
    Dim outputIndex As Integer
    
    ' 出力配列のサイズを決定
    ReDim outputArray(1 To UBound(DataArray, 1) * UBound(DataArray, 2))

    ' 2次元配列を1次元配列に変換
    outputIndex = 1
    For j = LBound(DataArray, 2) To UBound(DataArray, 2)
        For i = LBound(DataArray, 1) To UBound(DataArray, 1)
            If Not IsEmpty(DataArray(i, j)) Then
                outputArray(outputIndex) = DataArray(i, j)
            End If
            outputIndex = outputIndex + 1
        Next i
    Next j
    
    createDataRight = outputArray
End Function

種類出力

' **************************************************
' 種類番号振り分け
' **************************************************
Function KindOutput(cell As Range)
    Select Case True
        Case cell Like "待機*"
            KindOutput = 0
        Case cell Like "走行*"
            KindOutput = 1
        Case cell Like "急速充電*"
            KindOutput = 2
        Case cell Like "200V充電*"
            KindOutput = 3
        Case cell Like "充電前冷却*"
            KindOutput = 4
    End Select
End Function


' **************************************************
' 指定した値の種類値を返す
' **************************************************
Function SumKindOutput(targetCell As Range, searchRange As Range)
    Dim searchArray As Variant
    Dim outputCount As Long
    Dim rngMin As Long
    Dim rngMax As Long
    Dim i As Long
    
    searchArray = searchRange.Value
    
    rngMin = 0
    
    For i = 1 To UBound(searchArray, 2)
        rngMax = rngMin + searchArray(1, i)
        If rngMin < targetCell And rngMax >= targetCell Then
            SumKindOutput = searchArray(2, i)
            Exit For
        End If
        rngMin = rngMax
    Next i
End Function