You Look Too Cool

Sub 文字列ピボット()
    Dim rows(1000) '行ラベル全体
    Dim cols(1000) '列ラベル全体
    Dim vals(1000) '値(セルの内容)
    Dim heads(3) '列番号
    options = Array("行ラベル", "列ラベル", "値(セルの内容)")
    '軸の設定(どの列を軸にし、どの列をまとめるか)
    c = 1
    optionText = ""
    Do
        If optionText <> "" Then
            optionText = optionText & Chr(13)
        End If
        optionText = optionText & c & " : " & Cells(1, c)
        c = c + 1
    Loop Until Cells(1, c) = ""
    For i = 1 To 3
        res = InputBox("番号を入力。" & Chr(13) & optionText, options(i - 1), i)
        If res = "" Then
            Exit Sub
        Else
            heads(i) = CInt(res)
        End If
    Next i
    'データの取得
    rowLabel = Cells(1, heads(1))
    colLabel = Cells(1, heads(2))
    x = 0
    Do
        rows(x) = Cells(x + 2, heads(1))
        cols(x) = Cells(x + 2, heads(2))
        vals(x) = Cells(x + 2, heads(3))
        x = x + 1
    Loop Until Cells(x + 2, 1) = ""
    rowsNew = array_unique(rows) '行ラベル(重複なし)
    colsNew = array_unique(cols) '列ラベル(重複なし)
    'ピボットテーブル
    Worksheets.Add
    '軸
    Cells(1, 1) = rowLabel & "＼" & colLabel
    '行ラベル
    For r = 0 To UBound(rowsNew)
        Cells(r + 2, 1) = rowsNew(r)
    Next r
    '列ラベル
    For c = 0 To UBound(colsNew)
        Cells(1, c + 2) = colsNew(c)
    Next c
    '値
    For r = 0 To UBound(rowsNew)
        For c = 0 To UBound(colsNew)
            For x = 0 To UBound(vals)
                If rows(x) = rowsNew(r) And cols(x) = colsNew(c) Then
                    temp = vals(x)
                    moto = Cells(r + 2, c + 2)
                    If moto <> "" Then
                        temp = moto & Chr(13) & Chr(10) & temp
                    End If
                    Cells(r + 2, c + 2) = temp
                End If
            Next x
        Next c
    Next r
End Sub
Function array_unique(arrs)
    ReDim temps(UBound(arrs))
    x = 0
    For i = 0 To UBound(arrs)
        If x = 0 Then
            temps(x) = arrs(i)
            x = x + 1
        Else
            flg = 0
            For j = 0 To x
                If temps(j) = arrs(i) Then
                    flg = 1
                    Exit For
                End If
            Next j
            If flg = 0 Then
                temps(x) = arrs(i)
                x = x + 1
            End If
        End If
    Next i
    ReDim rets(x - 1)
    For i = 0 To x - 1
        rets(i) = temps(i)
    Next i
    array_unique = rets
End Function