Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。AdobeのScriptにも興味が少し。。

配列扱いメモ 

とても久しぶりに書くことになります。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 '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

自分用なので結果のSSは載せません。

ただ,少ないデータでやった感じでは,抽出,列削除,ソート等なんとなくうまくいってる風です。

とりあえず汎用のパーツだけ作ったけど 抽出,ソート,シートへ貼ることさえできれば普段やる仕事は全部できるから,けっこう用意できた気がします。

明日職場で去年のデータひっぱりだしてこのコード使ってみて,想定通り動くか試してみよう。

うまくいくかなぁ。



・・・ドメイン解除したりしたため,リンクとか切れまくりですが,いつか暇があればきちんとしようかな。。 わかりませんけど・・。