2022-03-28

VBA100本ノック 25本目：マトリックス表をDB形式に変換

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。

今回のお題は、マトリックス（行列）表からＤＢ（テーブル）形式への変換。
列数は、登場する日付の最大値と最小値の差から求めてみた。従って、例えば
土日が無いなど不連続なデータの場合は成立しない。
※その場合は、使用する列数などで求めるべきか。

行数は、部門数と区分数を変数に持つことで対応。マトリックスから自動で
読み取ってはいないので、確実性には欠けるかもしれない。

ということで、作成したのがこちら。

Sub VBA_100Knock_025()

        Sheets("売上").Select

    ' 日付。
    Dim dMax As Long
        dMax = WorksheetFunction.Max(Rows(1)) - _
               WorksheetFunction.Min(Rows(1)) + 1
    ' 部門数。
    Dim DeptNumber As Long
        DeptNumber = 5
    ' 区分数。
    Dim ItemNumber As Long
        ItemNumber = 2
    ' 並び替えたデータを格納するための配列。
    Dim arr() As Variant
    ReDim arr(dMax * DeptNumber * ItemNumber, 3)
    ' ラベル行のデータ作成。
        arr(0, 0) = "部門"
        arr(0, 1) = "区分"
        arr(0, 2) = "日付"
        arr(0, 3) = "金額"
    
    ' マトリックス形式の表範囲。
    Dim SrcRange As Range
    Set SrcRange = Range("A1").CurrentRegion
    Dim r As Long
    Dim c As Long
    Dim i As Long: i = 1
        For r = 2 To SrcRange.Rows.Count
            For c = 3 To dMax + 2
                ' 結合セル対策。
                If SrcRange(r, 1) = vbNullString Then
                    arr(i, 0) = arr(i - 1, 0)
                Else
                    arr(i, 0) = SrcRange.Cells(r, 1)
                End If
                arr(i, 1) = SrcRange.Cells(r, 2)
                arr(i, 2) = SrcRange.Cells(1, c)
                arr(i, 3) = SrcRange.Cells(r, c)
                i = i + 1
            Next
        Next
    
    Dim Sh As Worksheet
    Set Sh = Sheets.Add
        Sh.Name = "売上ＤＢ"
        Sh.Range("A1").Resize(dMax * DeptNumber * ItemNumber + 1, 4) = arr
End Sub

実行した結果が ↓ こちら。

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-03-21

0.1を２進数で求めようとして、その大変さに気づいた話

Excel 試してみた

前回は、２進数の求め方を自分なりに整理してみた。
infoment.hatenablog.com
今回は、小数点以下の数を2進数で求めるお話。
f:id:Infoment:20220321225639p:plain

前回紹介したように、０以上の場合、低い位（つまり０に近いところ）から
順に、その位に入る数を求めていった。小数点以下の場合も、同様の考え方
で良いらしい。

↓ 10進法の数字を10進法に変換するの図 ↓
f:id:Infoment:20220321230356p:plain

私のイメージするところでは、まず、小数点以下の数字が歯磨き粉チューブの
ようなものに収まっているところを連想する。
f:id:Infoment:20220321231917p:plain

１０進数なら、このチューブをギュッと握ると、中の数が１０倍される。桁が
上がって飛び出してきた数字が、その桁に収まる数字だ。何も出てこないなら、
その桁には０が入る。それを、０以外の数字が無くなるまで続ける。

例えば２進数なら、こんな感じだ。チューブを握るたび、２倍されていく。
f:id:Infoment:20220321232359p:plain

と、ここで気づいた。0.1って、どうなるんだ？
f:id:Infoment:20220321232825p:plain

ひょっとして、これは終わらない？
そうか、だから ↓ こうなのか。
f:id:Infoment:20220321232924p:plain

なるほど、ようやくちゃんと理解できた気がする。

参考まで。

2022-03-19

２進数の求め方を説明しようとしたらできなかった話

Excel 試してみた

例えば、10進数における「123」を2進数で表すとき。
はるか昔、↓こんな計算方法を習った。
f:id:Infoment:20220319155423p:plain
画像の引用元はこちら。
k3su.xyz
先日長男から、「何でこれで求まるのか」と訊かれて説明しようとして、
言葉に詰まってしまった。はて、何でだろう。分かっていたつもりだった
のに、うまく説明できない。検索してみても、「なぜ」の部分が語られて
いないものばかり。

そこで、考えてみた。
f:id:Infoment:20220319155928p:plain

例えば「123」を10で割ると、1桁目の数字が「余り」として現れる。
$123=12×10+3$
1桁目の数字を除いて100で割ると、2桁目の数字を10の位に持つ数字が
余りとして現れる。
$120=1×100+20$
これを繰り返せば、 $10^n$ で割った余りとして、 $n-1$ 桁の数字を
求めることができる。

↓ 10進法の数字を10進法に変換するの図 ↓
f:id:Infoment:20220319161349p:plain

従って、２進数の場合も同じ操作を繰り返せば、変換した結果を得ること
ができると考えた。しかし実際、この理屈だと２回目の計算ですぐに破綻
してしまう。
↓ 余りが２になるの図

なぜかと考えたが、おそらくは２進法に於いて「４で割る」こと自体が
ありえない操作なのだろうという、自分なりの結論に。

そこで、先の10進法における考え方を次のように修正した。
f:id:Infoment:20220319161846p:plain

先の計算で出た商を、その次の桁を求めるための「割られる数」にする。
これにより、10進数であれば常に10で割ればよいし、ｎ回目の割り算で
現れるｎ－１桁目の数値は常に１桁の整数として求めることができる。

これを２進数の計算に当て嵌めると、こんな感じだ。
f:id:Infoment:20220319162431p:plain

なるほど、これが冒頭の計算方法に繋がる訳か。ここまで整理すると
自分の中で、冒頭の計算方法が「当たり前のことを言っている」こと
がわかる。そして冒頭の表記方法を考えた人、何て賢いんだと思わず
感嘆。

また、分かってしまえば何進法であっても、現在より小さな進数に
変換するときは同様に計算可能であることもわかる。
【５進数の場合】
f:id:Infoment:20220319163022p:plain

【16進数の場合】
f:id:Infoment:20220319163259p:plain

ということで、今日はちょっとスッキリした一日でした。

参考まで。

2022-03-11

Excelで二個の平方数の和を求める

Excel VBA 作ってみた

前回は、Excelで素因数分解をやってみた。
infoment.hatenablog.com
なぜ、素因数分解をやってみたか。そもそもの切っ掛けは、こちらの動画を
見たことだった。
※再生すると音が出るので、ご注意ください。
youtu.be

合成数が２つの平方数の和で表される条件は、
４で割ると３余る素因数が全て平方である

というわけで、やってみた。
f:id:Infoment:20220311223146p:plain

まず、動画同様「二個の平方数の和」をWikipediaで調べてみた。
ja.wikipedia.org
どうやら「フェルマーの二平方定理」を満たせば、二個の平方数の和を持つと
言えるらしい。

そこでまず、同定理を満たすか否かを返す関数を作ってみた。この中で使用する
PrimeFactorDictについては、前回分を参照してほしい。

' フェルマーの二平方定理に該当するか否か。
Function IsFermatsTwoSquareTheorem(num As Long) As Boolean
    Dim Dict As Object
    Set Dict = PrimeFactorDict(num)
    
    Dim myKey As Variant
        For Each myKey In Dict.Keys
            If myKey Mod 4 = 3 Then
                If WorksheetFunction.IsOdd(Dict(myKey)) Then
                    Exit Function
                End If
            End If
        Next
        
        IsFermatsTwoSquareTheorem = True
End Function

これでFalseが返れば、そもそも二個の平方数の和ではないということに。
Trueが返る場合のみ、地道に計算することにした。

例えば「20」で考える。

20 － 1^2＝19　←　√19は整数ではない。
20 － 2^2＝16　←　√16＝4
20 － 2^3＝12　←　√12は整数ではない。

のように評価していく。となると、計算結果が整数か否かを判別する関数が
欲しくなる。作ってみた。

' ある値が整数であるか否かの判定。
Function IsIntegralValue(num As Double) As Boolean
    If num - WorksheetFunction.RoundDown(num, 0) = 0 Then
        IsIntegralValue = True
    End If
End Function

あとは、先程の理屈をコード化するだけだ。

' 二個の平方数の和を求める関数。
Function GetTwoSquareNumber(num As Long) As Variant
    Dim arr As Variant
        arr = Array()
        If Not IsFermatsTwoSquareTheorem(num) Then
            GetTwoSquareNumber = arr
            Exit Function
        End If
    
    Dim i As Long
    Dim j As Long
        Do
            j = num - i ^ 2
            If j < 0 Then
                Exit Do
            ElseIf IsIntegralValue(j ^ 0.5) Then
                If i <= j ^ 0.5 Then
                    ReDim Preserve arr(UBound(arr) + 1)
                    arr(UBound(arr)) = Array(i, j ^ 0.5)
                Else
                    Exit Do
                End If
            End If
            
            i = i + 1
        Loop
        
        GetTwoSquareNumber = arr
End Function

この関数は答えを配列で返しているので、文字列で解り易く返してみよう。

Function 二個の平方数の和(num As Long) As String
    Dim arr As Variant
        arr = GetTwoSquareNumber(num)
        If UBound(arr) = -1 Then
            二個の平方数の和 = "解無し"
            Exit Function
        End If
        
    Dim i As Long
    Dim temp() As Variant
    ReDim temp(UBound(arr))
        For i = 0 To UBound(arr)
            temp(i) = arr(i)(0) & "と" & arr(i)(1)
        Next
        
        二個の平方数の和 = Join(temp, "，")
End Function

さて、動画の答えや如何に。
f:id:Infoment:20220311224551p:plain

結果、2146だけが二個の平方数の和を二組持つことが分かった。なるほど。

ということで今回も、数学で遊んでみた。フェルマーの二平方定理というものを
私は今回初めて知った。また、VBAで計算する過程で、その仕組みを知ることが
できた。理解を深める一つの手法として、お勧めです。

参考まで。

2022-03-06

Excelで素因数分解

Excel VBA 作ってみた

前回は、Excelで素数判定をやってみた。
infoment.hatenablog.com
なぜ、素数判定をやってみたか。そもそもの切っ掛けは、Excelで素因数分解って
どんな風にやれるかな？と思ったこと。

というわけで、やってみた。
f:id:Infoment:20220306202346p:plain

素因数分解 (そいんすうぶんかい、英: prime factorization) とは、ある正の整数を素数の積の形で表すことである。

ja.wikipedia.org

そこで、二つの関数を作成してみた。

引数で与えられた数に含まれる、素数とその数を収めた辞書
1. の情報を元に、a^m*b^nのような表記を作成する関数

実際に作成したのがこちら。

' 素因数分解した結果を格納する辞書。
' keyに約数となる素数を、itemにその数を持つ。
Function PrimeFactorDict(num As Long) As Object
    Dim i As Long
    Dim iMax As Long
    
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    Dim temp As Long
        temp = num
        ' tempの約数を探して、あればそれでtempを割って
        ' いく。tempが素数になるまで続ける。
        Do
            iMax = WorksheetFunction.RoundUp(temp ^ 0.5, 0)
            For i = 2 To iMax
                If temp Mod i = 0 Then
                    If Dict.Exists(i) Then
                        Dict(i) = Dict(i) + 1
                    Else
                        Dict(i) = 1
                    End If
                    temp = temp / i
                    Exit For
                End If
            Next
            
            ' 素数であればLoopを抜ける。
            If i > iMax Then
                Dict(temp) = 1
                Exit Do
            ' ２のべき乗対応。
            ElseIf i = iMax Then
                Dict(temp) = Dict(temp) + 1
                Exit Do
            End If
        Loop
    
    Set PrimeFactorDict = Dict
End Function

' 素因数分解の結果を文字列で出力。
Function PrimeFactorization(num As Long) As String
    Dim Dict As Object
    Set Dict = PrimeFactorDict(num)
    
    Dim arr() As Variant
    ReDim arr(1 To Dict.Count)
    
    Dim i As Long: i = 1
    Dim myKey As Variant
        For Each myKey In Dict.Keys
            If Dict(myKey) = 1 Then
                arr(i) = myKey
            Else
                arr(i) = myKey & "^" & Dict(myKey)
            End If
            i = i + 1
        Next
        
        PrimeFactorization = Join(arr, "*")
End Function

実際の計算結果がこちら。
f:id:Infoment:20220306203133p:plain

割といい感じだ。次回に続きます。

参考まで。

2022-03-01

素数判定（再び）

Excel VBA 作ってみた

２年ほど前に、素数判定のユーザー定義関数を作ってみた。
infoment.hatenablog.com
見返してみると、改善可能な個所がいくつかあった。この２年で、
私も少し成長したようだ（当社比）。
f:id:Infoment:20220301230026p:plain

といっても、改善点は以下の二つのみ。

４以上の偶数は素数ではない。
偶数で割りきれるかどうかは評価しない。

実際に作成し直したのがこちら。

' 素数判定。
Function IsPrime(num As Long) As Boolean
        ' １以下は素数ではない。
        If num <= 1 Then
            Exit Function
        ' ２と３は素数。
        ElseIf num <= 3 Then
            IsPrime = True: Exit Function
        ' ２を除く偶数は素数ではない。
        ' ※２については直前で判定済み。
        ElseIf WorksheetFunction.IsEven(num) Then
            Exit Function
        End If

    Dim i As Long
    Dim iMax As Long
        ' 素数判定は、その数の平方根までで可。
        iMax = WorksheetFunction.RoundUp(num ^ 0.5, 0)
        
        ' この時点で評価するのは奇数のみなので、偶数で
        ' 割れば必ず奇数の余りがでる。従って奇数でのみ
        ' 余りを確かめている。
        For i = 3 To iMax Step 2
            ' iで割り切れる（＝iが約数）なら、素数ではない。
            If num Mod i = 0 Then Exit Function
        Next
        
        IsPrime = True
End Function

f:id:Infoment:20220301230657p:plain

過去に作ったものの見直しは、やはり必要かも。

参考まで。

2022-02-27

VBA100本ノック 24本目：全角英数のみ半角

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220227150506p:plain

文字列を一文字ずつ判定して、半角や大文字に直していく。
参照設定を使わないで済むよう、今回はLike演算子でやってみよう。

Function VBA_100Knock_024(source As Variant) As String
    Dim i As Long
    ' 文字を一文字ずつ格納するための配列。
    Dim arr() As Variant
    ReDim arr(1 To Len(CStr(source)))
    Dim temp As String
        For i = 1 To UBound(arr)
            arr(i) = Mid(source, i, 1)
            ' 半角大文字に変換できたものは、変換すべきものと判定する。
            temp = StrConv(arr(i), vbNarrow + vbUpperCase)
            If temp Like "[A-Z0-9]" Then
                arr(i) = temp
            End If
        Next
        
        VBA_100Knock_024 = Join(arr, vbNullString)
End Function

f:id:Infoment:20220227151704p:plain

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。