配列扱いメモ　 - インストールレスプログラミング( ´ー`)

とても久しぶりに書くことになります。vbaはたまーに組んでますが，今年はそれ以外の仕事が多くて去年のようにはいきません。

いろいろ，すっかり忘れてしまいました。ただ，時期的にExcelで配列を扱わないといけないので，いろいろ組んでいたら，結局自分がいろいろと書き残したこのページを久しぶりに見にきました。

でも，去年がんばった分，excelの処理であっても一時シート作ってそこでごちゃごちゃやって，貼り付けた後一時シートを消す，という風には頭が動かない。

配列でちゃちゃっとやりたいな，と思うところは以前とはかわったようです。

ただ，VBAの知識がある人がまったく職場にいない可能性が今あるので，引き継ぐときは，一時シート上で処理をする方法も書きたいところではありますね。。

さて，久しぶりに自分のページを見に来た理由は，他の方のページを参考にバブルソートで降順並べ替えにすると，またしても安定ソートなのに同じキーに対してデータが入れ替わってしまったため。

前悩んだよなぁと思い，見に来ました。

まだコレクションとか思い出せないので使えませんが，以前よりかなりデータ量は少ない状態で今回はやれるので，配列のみでやってしまうことにしています。

自分用コードなので，間違いなどあっても保証はできません。悪しからず。

元データを仮に次のように用意
f:id:chemiphys:20180114231400p:plain

コードは今のところここまで

Option Explicit

Sub メイン処理仮()
Dim SSht As Worksheet: Set SSht = ThisWorkbook.Worksheets("Sheet1")
Dim データ() As Variant
Dim 最下行 As Long: 最下行 = SSht.Cells(Rows.Count, 1).End(xlUp).Row
Dim 項目数 As Long: 項目数 = SSht.Cells(1, Columns.Count).End(xlToLeft).Column
ReDim データ(1 To 最下行, 1 To 項目数)
データ = SSht.Range(SSht.Cells(1, 1), SSht.Cells(最下行, 項目数)).Value

Dim i As Long, j As Long, 抽出数 As Long
Dim 抽出 As Variant

抽出 = レコード抽出(データ, 2, "C")

Dim 抽出2 As Variant
抽出2 = 不要列削除(抽出, "5,6,7") '削除列の順番は必ず小さい順に書くこと。

Dim 抽出3 As Variant
抽出3 = ソート(抽出2, 4, True)

Dim 抽出4 As Variant
抽出4 = ソート(抽出2, 4, False)

Call 一時シート作成
Dim TSht As Worksheet: Set TSht = ThisWorkbook.Worksheets("一時")

Call シートへ転記(抽出, TSht.Range("a1"))
Call シートへ転記(抽出2, TSht.Range("a10"))
Call シートへ転記(抽出3, TSht.Range("a20"))
Call シートへ転記(抽出4, TSht.Range("a30"))
End Sub

Function レコード抽出(ByVal 配列 As Variant, 項目列 As Long, 抽出値 As String) As Variant
Dim 項目数 As Long, データ数 As Long
データ数 = UBound(配列, 1)
項目数 = UBound(配列, 2)
Dim 一時配列() As Variant
Dim i As Long: i = 1
Dim j As Long
Dim 抽出数 As Long: 抽出数 = 1
ReDim 一時配列(1 To 300, 1 To 項目数)

Do
    If 配列(i, 項目列) = 抽出値 Then
        For j = 1 To 項目数
            一時配列(抽出数, j) = 配列(i, j)
        Next
        抽出数 = 抽出数 + 1
    End If
    i = i + 1
Loop Until i = データ数 + 1

抽出数 = 抽出数 - 1 '１多くなってループを抜けるので

Dim 一時配列2() As Variant
一時配列2 = WorksheetFunction.Transpose(一時配列)
ReDim Preserve 一時配列2(1 To 項目数, 1 To 抽出数)

レコード抽出 = WorksheetFunction.Transpose(一時配列2)
    
End Function

Function 不要列削除(ByVal 配列 As Variant, 不要列 As String)
Dim 一時配列() As Variant
ReDim 一時配列(1 To UBound(配列, 1), 1 To UBound(配列, 2))
Dim i As Long: i = 1
Dim j As Long
Dim k As Long
Dim flg As Boolean
Dim 削除列数 As Long: 削除列数 = UBound(Split(不要列, ",")) + 1

For k = 削除列数 - 1 To 0 Step -1
    For i = 1 To UBound(配列, 1)
        flg = False
        For j = 1 To UBound(配列, 2)
            If j = Split(不要列, ",")(k) Then
                flg = True
            Else
                If flg = False Then 一時配列(i, j) = 配列(i, j) Else 一時配列(i, j - 1) = 配列(i, j)
            End If
        Next
    Next
    配列 = 一時配列
Next

ReDim Preserve 配列(1 To UBound(配列, 1), 1 To UBound(配列, 2) - 削除列数)

不要列削除 = 配列
End Function

Function ソート(ByVal 配列 As Variant, ソート列番号 As Long, 昇順 As Boolean)
    Dim 入替用 As Variant
    Dim i As Long, j As Long, k As Long
    Dim flg As Boolean
    For i = LBound(配列, 1) To UBound(配列, 1) - 1
        For j = LBound(配列, 1) To UBound(配列, 1) - i
            If 昇順 Then
                If 配列(j, ソート列番号) > 配列(j + 1, ソート列番号) Then flg = True Else flg = False
            Else
                If 配列(j, ソート列番号) < 配列(j + 1, ソート列番号) Then flg = True Else flg = False
            End If
            If flg Then
                For k = LBound(配列, 2) To UBound(配列, 2)
                    入替用 = 配列(j, k)
                    配列(j, k) = 配列(j + 1, k)
                    配列(j + 1, k) = 入替用
                Next
            End If
        Next
    Next
    ソート = 配列
End Function

Sub シートへ転記(ByVal 配列 As Variant, セル As Range)
セル.Resize(UBound(配列, 1), UBound(配列, 2)).Value = 配列
End Sub

Sub 一時シート作成()
Application.DisplayAlerts = False
On Error Resume Next
    ThisWorkbook.Worksheets("一時").Delete
On Error GoTo 0
ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = "一時"

Application.DisplayAlerts = True
End Sub