0以下は0に、その他はそのままにする

まずは、ワークシート関数でやってみます。

IF関数を使います。
たとえば、
A1-B1の計算をして
その答えを0以下は0に、その他はそのままにするには

=IF(A1-B1<0,0,A1-B1)

とセルに入力します。

もしA1-B1が0より小さいなら値を0に、
そうでないなら値をA1-B1にする働きをします。

下のシートの画像のA列、B列には

=RAND()

で乱数をいれています。
C列の1行目は

=A1-B1

D列の1行目が

=IF(A1-B1<0,0,A1-B1)

になっています。
C列、D列は2行目以降オートフィルで入力。

以上の内容をVBAでやります。

コードはこちら

Sub macro110129a()
'0以下は0に、その他はそのままにする

    'A列、B列
    Range("A1:B10").Formula = "=RAND()"
    'C列
    Range("C1:C10").Formula = "=A1-B1"
    'D列
    Range("D1:D10").Formula = "=IF(A1-B1<0,0,A1-B1)"
   
End Sub

次はワークシート関数を使わない方法です。

if文で条件分岐すればいいのですが、
単純な条件でifを使って
コードが長くなるのも見にくいので
なにかいい関数はないかと
VBAのヘルプで関数を調べてみたら
Switch関数が見つかったのでそれを使います。

Switch関数の使い方の簡単な説明：

Switch(式1, 値1, 式2, 値2, 式3, 値3, ・・・)

式を順に評価していき
最初に真(True)になる式に関連付けられた値(式1なら値1)を返す。

ほぼIf文の代わりに使えそうです。

コードはこちら

Sub macro110129b()
'0以下は0に、その他はそのままにする

    'A列、B列に乱数
    Range("A1:B10").Formula = "=RAND()"
    Range("A1:B10") = Range("A1:B10").Value
        '↑再計算されてしまうので値に変換
    'C列にA列-B列
    Range("C1:C10").Formula = "=A1-B1"
   
    Dim i As Integer
    Dim Val1 As Single
   
    'D列
    For i = 1 To 10
        Val1 = Cells(i, 1) - Cells(i, 2)
        Cells(i, 4) = Switch(Val1 < 0, 0, True, Val1)
        '0より小さいなら0
        'そのほかはそのまま
    Next i
   
End Sub

今までは計算しながら条件判断、入力をしていましたが、
次は既にある値を条件判断し値を変更します。

For Each Nextを使って指定範囲内のセルをまわして
If文で条件分岐して値を変更します。

コードはこちら

Sub macro110129c()
'0以下は0に、その他はそのままにする

    Dim i As Integer, j As Integer
   
    'Range("A1:E10")に適当な値を入れる
    For i = 1 To 10
        For j = 1 To 5
            Cells(i, j) = Rnd() - Rnd()
        Next j
    Next i
   
    Stop
   
    '判断
    Dim obj As Object
    For Each obj In Range("A1:E10")
        If obj < 0 Then obj = 0
    Next obj
   
End Sub

実行例

Switch関数はいろいろ使えそうですね。

2011年センター試験、数学プログラム問題

2011年センター試験、数学プログラム問題が
新聞に載っていたので
それについてです。
問題全文は1月17日の新聞を参照してください。

問題を最初から解いている場面を想定したレポートです。

ん～今年はどんな問題かなー
え～っと

nを2以上の自然数とし
nが偶数ならば、nを2で割る。
nが奇数なら、nを3倍にして1を加える。
この操作をnが1になるまで繰り返す。

例えば10の場合は、

10 → 5 → 16 → 8 → 4 → 2 → 1

F(N)がNから始めて1になるまでの操作の回数で

F(10) = 6

で最初の問題はF(6)とF(11)を出すのね。
手で書いて出せばいいね。
矢印は省略するけど、

6 3 10 5 16 8 4 2 1
11 34 17 52 26 13 40 20 10 5 16 8 4 2 1

あとは数えて～
F(6) = 8　
F(11) = 14

5が出てからは当然ながら
5 16 8 4 2 1
と同じだね。

次はプログラム中の空欄を埋める問題
[エ]は
もしIが1ならもう操作しなくてもいいから
190、200、210のどれかだけど
確定できないから飛ばし。

次は[オ][カ][キ]の空欄ね～
オカキってせんべいを連想しちゃったよ～
こんな時に、
[オ]と[カ]と[キ]ね。

まず[オ]、
Iが偶数ならする操作ってことで
LET I=I/2

[カ]は～
残りの選択肢は
「GOTO」系か
「Cの計算」系かしかないからー
そんでもってCはCountのCだから操作の回数をいれる変数。
それで、
GOTOはやっぱり
Iが1かどうか確かめる130行に戻るわけだし
戻る前にCを1増やしとかないといけないので
C = C+1

[キ]はGOTO 130

これで[エ]がわかるね。
[エ]は[キ]GOTO 130の後行の210。

[ク]はN=24のとき180行が実行される回数か～
180行は、LET I=3*I+1
なのでIが奇数のときに実行される。
だから手で書いて奇数のときを数えればいい。

24 12 6 3 10 5 16 8 4 2 1

奇数は3と5の2回よって[ク]は2。

次からは恒例のプログラム一部変更問題だね。

F(N) <= 10 になるNだけ表示するようにするわけね～

For文でNを1からMまで変化させて
それぞれのF(N)を求めて
IF文でF(N) <= 10かどうかを判定するという流れ。

今更だけど、
F(N)はプログラム中ではCだね。

今までのプログラムをFor文で挟むだけみたいだから
簡単？かもね～

[ケ]は、「○○のときCを出力する」だから
当然C<=10。

[コ]は、選択肢の中に「NEXT」があるよ。
そういえばForに対するNextがまだないね。
FORの変数はNだから
[コ]は、NEXT N

ここでプログラムの基本中の基本を出すか～

次は最後の問題[サ]
変更後のプログラムでM=10を入れると
210行のPRINT文は何回実行されるか？

ん～っと
210行のPRINT文は
C<=10のとき実行されるから、
Nが1から10までのF(N)を手で書いて求めて
F(N)<=10になるNの数を数えれば解けるね。

まずは1から10までの数字を書く。

N	1	2	3	4	5	6	7	8	9	10
F(N)

F(1) = 0
F(2) = 2
F(4) = 3
F(8) = 4
F(10) = 6
は簡単。
F(10)は問題文中に書いてあるし～

N	1	2	3	4	5	6	7	8	9	10
F(N)	0	1		2				4		6

F(5)はこれを再利用すれば出るね。
10 → 5 → 16 → 8 → 4 → 2 → 1
つまり
5 → 16 → 8 → 4 → 2 → 1
でF(5)=5

他にも再利用できるものがないか探してみると
F(6)とF(11)を解いたとき書いたヤツが使えるかも…
ってF(6)ももうわかってるね。

6 3 10 5 16 8 4 2 1
11 34 17 52 26 13 40 20 10 5 16 8 4 2 1

だから
F(6)=8
F(3)=7

N	1	2	3	4	5	6	7	8	9	10
F(N)	0	1	4	2	5	8		4		6

残りは7と9。
大きいほうの9からF(N)を求めよう。
途中で7が出てくるかもしれないし…

9 28 14 7

おっ、7来た。

9 28 14 7 22 11 34 …

11って前に出てきたよね。えっと
F(11) = 14
つまり9も7もF(N)は10より大きい。

N	1	2	3	4	5	6	7	8	9	10
F(N)	0	1	4	2	5	8	×	4	×	6

[サ]は８、終わり。

ってな感じでできたらいいですよね～

問題中のプログラムをVBAでやってみます。

コードはこちら

Sub macro110122a()
'センター試験2011
'数学プログラム問題
'問題は2011/01/17の新聞で

    Dim N As Integer
    Dim I As Integer
    Dim C As Integer
   
    N = InputBox("2以上10^5以下の自然数Nを入力してください")
    Let I = N
    Let C = 0
Step130:
    If I = 1 Then GoTo Step210
    If Int(I / 2) * 2 = I Then
        Let I = I / 2
        GoTo Step190
    End If
    Let I = I * 3 + 1
Step190:
    C = C + 1
    GoTo Step130
Step210:
    Debug.Print ("F(" & N & ") = " & C)
   
    'End
End Sub

Sub macro110122b()
'センター試験2011
'数学プログラム問題(変更後)
'問題は2011/01/17の新聞で

    Dim N As Integer, M As Integer
    Dim I As Integer
    Dim C As Integer
   
    M = InputBox("2以上10^5以下の自然数Mを入力してください")
    For N = 1 To M
        Let I = N
        Let C = 0
Step130:
        If I = 1 Then GoTo Step210
        If Int(I / 2) * 2 = I Then
            Let I = I / 2
            GoTo Step190
        End If
        Let I = I * 3 + 1
Step190:
        C = C + 1
        GoTo Step130
Step210:
        If C <= 10 Then Debug.Print ("F(" & N & ") = " & C)
    Next N
   
    'End
End Sub

macro110122a実行中のダイアログ
Nの値を入力する。

macro110122a実行後のイミディエイト例

macro110122b実行中のダイアログ
Mの値を入力する。

macro110122b実行後のイミディエイト例

今年の問題は2段階目のひねりが
少ないように感じました。

年間予定表を作成する

一年の計は元旦にあり

ということで
元旦からは少し経ってしまいましたが
年間予定表をVBAで作成したいと思います。

1年間を1枚の紙に表すのに
左から右へ1月から12月までの月を、
上から下へ1日から月末までの日を配置します。

日付の表示は、日付（曜日）になっていますが
セルには日付型の数値が入っていますので
フォーマットを変更するだけで
表示の仕方を変更できます。

祝日の取得は
以前の記事「 任意の年の祝日を取得する 」を参照してください。

大体A3サイズに入る大きさにしました。

コードはこちら

Sub macro110115a()
'MyYear年間予定表
   
    Const MyYear As Integer = 2011
   
    '祝日をWebから取得
    '参照https://yumem.cocolog-nifty.com/blog/2010/03/post-f84a.html
    Call GetHollydays(MyYear)
   
    Dim DAY1 As Date, DAY2 As Date
    Dim SPAN As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim obj As Object
   
    Sheets.Add
    Cells(1, 1) = MyYear & "年　予定表"
    Cells(1, 1).Font.Size = 24
   
    For i = 1 To 12
        DAY1 = MyYear & "/" & i & "/01" '月始め
        DAY2 = DateAdd("m", 1, DAY1) - 1 '月末
       
        Cells(2, i * 2 - 1) = i & "月"
        Cells(2, i * 2 - 1).Font.Size = 16
        With Range(Cells(2, i * 2 - 1), Cells(2, i * 2))
            .Merge
            .HorizontalAlignment = xlCenter
        End With
       
        '日付の列の幅
        Columns(i * 2 - 1).ColumnWidth = 5.5
        '隣の空白の列の幅
        Columns(i * 2).ColumnWidth = 9
       
        SPAN = DAY2 - DAY1 + 1 'i月の日数
       
        For j = 0 To SPAN - 1
            Set obj = Range(toA1("R" & j + 3 & "C" & i * 2 - 1 & _
                ":R" & j + 3 & "C" & i * 2))
            
            'i月j日のセルとその隣の装飾指定
            obj.Borders.LineStyle = xlContinuous
            obj.Borders.Weight = xlThin
            obj.Borders.ColorIndex = 1
            
            'i月j日のセルの装飾指定
            With Cells(j + 3, i * 2 - 1)
                .Value = DAY1 + j
                .NumberFormat = "d(aaa)"
                .Borders(xlEdgeRight).LineStyle = xlNone
                .VerticalAlignment = xlTop
               
                '土日色づけ
                If Weekday(.Value) = 1 Then
                    '日曜日
                    .Interior.ColorIndex = 38
                    Cells(j + 3, i * 2).Interior.ColorIndex = 38
                ElseIf Weekday(.Value) = 7 Then
                    '土曜日
                    .Interior.ColorIndex = 37
                    Cells(j + 3, i * 2).Interior.ColorIndex = 37
                End If
            End With
            
        Next j
    Next i
   
    '全体の行の高さ指定
    Rows("3:" & Range("A2").End(xlDown).Row).RowHeight = 24
   
    '祝日を追加
    Dim SheetA As Worksheet
    Set SheetA = Sheets("祝日" & MyYear)
    For i = 3 To SheetA.Range("A1").End(xlDown).Row
        Set obj = SheetA.Cells(i, 1)
       
        '祝日に該当する日付のセルの色づけ
        Cells(Day(obj) + 2, Month(obj) * 2 - 1).Interior.ColorIndex = 38
       
        '空白のセルに祝日の名称をいれ装飾
        With Cells(Day(obj) + 2, Month(obj) * 2)
            .Interior.ColorIndex = 38
            .Value = SheetA.Cells(i, 2)
            .Font.Size = 7
            .VerticalAlignment = xlTop
        End With
    Next i
   
End Sub

macro110115a実行後のシートの一部

これをA3用紙に印刷してみましたが
ちょっと小さいですね。
余白を最小限にしてA3で印刷すれば
２、３個の予定が書けます。

この土日はセンター試験ですね。
今年はどんなプログラム問題ですかね～

友愛数

先日テレビで放送されていた映画
『博士が愛した数式』を見ていたら
友愛数というものが出てきました。

この友愛数をVBAで求めてみました。

映画自体は良かったです。

記憶が80分しか持たない博士。
嫌なことは覚えなくて済むと思いきや、
毎朝、記憶が80分しかもたないことに
一人絶望していた。
といった対比がよかったです。

博士のヌボーとした表情に
とてもリアリティーを感じていたのですが、
映画『亡国のイージス』が数日後テレビで放映されていたので
見ていたら
博士役だった寺尾聰が出ていて同じ表情だったので
ちょっとがっかりしました。

さて、友愛数についての説明です。

２つの自然数m, nについて
mのm自身除いた約数の和がn
nのn自身除いた約数の和がmであるとき
mとnを友愛数と呼ぶ。

たとえば、
220 : 1+2+4+5+10+11+20+22+44+55+110 = 284
284 : 1+2+4+71+142 = 220

コードはこちら

Sub macro110108a()
'友愛数を求める

    Sheets.Add
    Cells(1, 1) = "友愛数"
   
    Dim i As Long, j As Long
    Dim c As Object
    Dim i_divsum As Long
    Dim i_divsum2 As Long
   
    For i = 2 To 10 ^ 5
   
        '既に同じ組み合わせが出ていたら次のiへ
        If TypeName(Columns("B").Find(i)) <> "Nothing" Then
            For Each c In Columns("B").Find(i)
                If c = i Then
                    GoTo Next_i
                End If
            Next c
        End If
       
        i_divsum = 0
        i_divsum2 = 0
        'iの自身を除いた約数の和を求める
        For j = 1 To i - 1
            If i Mod j = 0 Then
                i_divsum = i_divsum + j
            End If
        Next j
       
        'i_divsumの自身を除いた約数の和を求める
        For j = 1 To i_divsum - 1
            If i_divsum Mod j = 0 Then
                i_divsum2 = i_divsum2 + j
            End If
        Next j
       
        If i = i_divsum2 Then
            If i <> i_divsum Then '完全数を排除
                'iとi_divsumは友愛数
                Rows(2).Insert
                Cells(2, 1) = i
                Cells(2, 2) = i_divsum
            End If
        End If
Next_i:
    Next i
   
End Sub

macro110108a実行後のシート

10万まで調べるには結構時間が掛かります。

重複を避けるところでFind関数を使ったのですが、
Find関数は数字の検索をするのには向いていないのでしょうか？

たとえば、284という数が入っているセルは
"28"で検索に引っ掛かります。
文字列扱いです。

文字列にしても「完全一致検索」は
Find関数だけではできないようですね。

配列をソートする

参照URL:
『 How to Use a Visual Basic Macro to Sort Arrays in Excel 』

上記ページによると
VBAで配列を直接ソートする方法はないようです。
代わりに2つの方法

Selection Sort
Bubble Sort

が例示されています。

訳して簡単に説明します。

Selection Sort

プログラムするのが簡単だが、
大きい配列ではthe Bubble Sortより遅い。

要素が１からnまでの配列でSelection Sortをする。

この配列の１からnまでの中で一番大きい要素を見つける。
これがn番目の要素でない(Indexがnより小さい)なら、
これをn番目と入れ替える。

それから、
１からn-1までの中で一番大きい要素を見つける。
これがn-1番目の要素でないなら、
これをn-1番目と入れ替える。

…

１から２までの中で一番大きい要素を見つける。
これが２番目の要素でないなら、
これを２番目と入れ替える。

Bubble Sort

Selection Sortよりプログラムするのが難しいが、
大きい配列をソートする場合はより速く効果的の傾向。

１からn-1までの要素をそれぞれ次の要素と比較し
次の要素のほうが小さいなら入れ替える。
これを入れ替えがなくなるまで繰り返す。

以上で訳終了。

Function SelectionSort、
Function BubbleSortNoteは共に昇順で並び替える方法で、
最後のほうのNoteで降順にする方法が書かれています。

昇順(ascending order)
降順(descending order)

この２つ
いつもどっちが大きいほうからで
どっちが小さいほうからか考えてしまします。

昇順が列の上から下の方向へ大きくなっていく、
降順が列の上から下の方向へ小さくなっていく。

言い換えると、
昇順が列の一番上に小さいものが来て、
降順が列の一番上に大きいものが来る。

列の”下へ向って昇っていく”というところが
感覚と合わないところですね。

さて
Function SelectionSort、Function BubbleSortNoteを改造して
昇順、降順を１つのプロシージャでできるようにします。

それには、引数Orderを１つ増やして
昇順、降順を指定します。

Order = 0 を昇順、
Order = 1を降順にします。

これをIf文で分岐するだけのことです。

コードはこちら

Function SelectionSort2(TempArray As Variant, Order As Integer)
'Option Base 1で実行
'Order = 0 昇順
'Order = 1 降順

    Dim MaxVal As Variant '最大値/最小値
    Dim MaxIndex As Integer
    Dim i, j As Integer
   
    If Order <> 0 And Order <> 1 Then
        MsgBox "Orderは0か1を指定してください。"
        Exit Function
    End If
    ' 配列の後ろから前へ
    For i = UBound(TempArray) To 1 Step -1

        '配列の最大要素の値とインデックス
        MaxVal = TempArray(i)
        MaxIndex = i

        ' 残りの要素とMaxValを比較しMaxValより大きいなら
        'その要素をMaxValにする
        For j = 1 To i
            If Order = 0 Then
                '昇順
                If TempArray(j) > MaxVal Then
                    MaxVal = TempArray(j)
                    MaxIndex = j
                End If
            ElseIf Order = 1 Then
                '降順
                If TempArray(j) < MaxVal Then
                    MaxVal = TempArray(j)
                    MaxIndex = j
                End If
            End If
        Next j

        ' 残りの要素の最大要素のインデックスがiでないなら
        'その要素とiを入れ替える
        If MaxIndex < i Then
            TempArray(MaxIndex) = TempArray(i)
            TempArray(i) = MaxVal
        End If
    Next i

End Function

Sub macro110101b()
'SelectionSort2使用例

    Sheets.Add
   
    Dim TheArray As Variant
    Dim i As Integer
   
    ' ソートする配列
    TheArray = Array(15, 8, 11, 7, 33, 4, 46, 19, 20, 27)
    Range("A1") = "SelectionSort元"
    For i = 1 To 10
        Cells(i + 1, 1) = TheArray(i)
    Next i

    ' ソート(昇順)
    Call SelectionSort2(TheArray, 0)
    Range("B1") = "昇順"
    For i = 1 To 10
        Cells(i + 1, 2) = TheArray(i)
    Next i
   
    ' ソート(降順)
    Call SelectionSort2(TheArray, 1)
    Range("C1") = "降順"
    For i = 1 To 10
        Cells(i + 1, 3) = TheArray(i)
    Next i
   
End Sub

Function BubbleSort2(TempArray As Variant, Order As Integer)
'Option Base 1で実行
'Order = 0 昇順
'Order = 1 降順

    Dim Temp As Variant
    Dim i As Integer
    Dim NoExchanges As Integer

    ' ループの終わりでNoExchanges = Trueで終了
    Do
        NoExchanges = True

        For i = 1 To UBound(TempArray) - 1
            If Order = 0 Then
                '昇順
                If TempArray(i) > TempArray(i + 1) Then
                    NoExchanges = False
                    Temp = TempArray(i)
                    TempArray(i) = TempArray(i + 1)
                    TempArray(i + 1) = Temp
                End If
            ElseIf Order = 1 Then
                '降順
                If TempArray(i) < TempArray(i + 1) Then
                    NoExchanges = False
                    Temp = TempArray(i)
                    TempArray(i) = TempArray(i + 1)
                    TempArray(i + 1) = Temp
                End If
            End If
        Next i
    Loop While Not (NoExchanges)

End Function

Sub macro110101a()
'BubbleSort2使用例

    Sheets.Add
   
    Dim TheArray As Variant
    Dim i As Integer
   
    ' ソートする配列
    TheArray = Array(15, 8, 11, 7, 33, 4, 46, 19, 20, 27)
    Range("A1") = "BubbleSort元"
    For i = 1 To 10
        Cells(i + 1, 1) = TheArray(i)
    Next i

    ' ソート(昇順)
    Call BubbleSort2(TheArray, 0)
    Range("B1") = "昇順"
    For i = 1 To 10
        Cells(i + 1, 2) = TheArray(i)
    Next i
   
    ' ソート(降順)
    Call BubbleSort2(TheArray, 1)
    Range("C1") = "降順"
    For i = 1 To 10
        Cells(i + 1, 3) = TheArray(i)
    Next i
   
End Sub

macro110101a実行後のシート

上の2つの方法は1次元配列しかソートできないので
使いにくいです。

それにしてもBubble Sortってなんで
バブルという名前なんでしょうか？
たくさんクルクルするからなんでしょうかね～