VBA100本ノック 38本目：1シートを複数シートに振り分け

Excel VBA 100本ノック

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

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

今回は、Indexで配列を一行ずつ切り取って振り分ける方式を採用。

Sub VBA_100Knock_38()
    ' 祝日の辞書作成。
    Dim HolidayDict As Scripting.Dictionary
    Set HolidayDict = New Scripting.Dictionary
    
    Dim i As Long
        With Sheets("祝日")
            For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                HolidayDict(.Cells(i, 1).Value) = .Cells(i, 2).Value
            Next
        End With
        
    ' 振り分け前情報。
    Dim SourceArray As Variant
        SourceArray = Sheets("売上").Range("A1").CurrentRegion
    
    Dim TargetSheet As Worksheet
    Dim TempArray As Variant
    Dim TargetDate As Date
        For i = 2 To UBound(SourceArray)
            ' 各レコードを切り出し。
            TempArray = WorksheetFunction.Index(SourceArray, i, 0)
            TargetDate = TempArray(1)
            If HolidayDict.Exists(TargetDate) Or _
               WorksheetFunction.Weekday(TargetDate, 2) >= 6 Then
                Set TargetSheet = Sheets("土日祝")
            Else
                Set TargetSheet = Sheets("平日")
            End If
                
            TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6) = TempArray
        Next
End Sub

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

参考まで。

VBA100本ノック 37本目：グラフの色設定

Excel VBA 100本ノック

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

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

今回は、

  1. グラフが一つしかない ⇒ 一つ目のグラフで決め打ち
  2. 最大値と最小値を編集 ⇒ 最大値、最小値で決め打ち

ということで、決め打ちが多い分だけコードが短くなった。

しかし、普段操作しない箇所についてのコードが多数あって、今回はいつにも
増して勉強になった。

ということで、作成したコードがこちら。

Enum ItemIndex
    eMin
    eMax
End Enum

Sub VBA_100Knock_37()
    ' 最小・最大の棒の色。
    Dim Color(ItemIndex.eMin To ItemIndex.eMax) As Long
        Color(ItemIndex.eMin) = rgbRed
        Color(ItemIndex.eMax) = rgbGreen
    Dim ItemNum(ItemIndex.eMin To ItemIndex.eMax) As Long
    ' 系列の値が記された範囲。
    Dim DataRange As Range
    Set DataRange = Range("B2:B11")
    ' 何度もWorksheetFunctionsと記述すると長くなるので、wfにセット。
    Dim wf As WorksheetFunction: Set wf = WorksheetFunction
        ' 最小値が系列の何番目かを求める。最大値も同様。
        ItemNum(ItemIndex.eMin) = wf.Match(wf.Min(DataRange), DataRange, 0)
        ItemNum(ItemIndex.eMax) = wf.Match(wf.Max(DataRange), DataRange, 0)
    
    Dim i As Long
    Dim Chart As Excel.Chart
    ' グラフは今回一つしかない。
    Set Chart = ActiveSheet.ChartObjects(1).Chart
        For i = ItemIndex.eMin To ItemIndex.eMax
            ' グラフの一つ目の系列（今回は一つしかない）の、最小・最大
            ' 各ポイントについて。
            With Chart.FullSeriesCollection(1).Points(ItemNum(i))
                ' 棒グラフ着色。
                .Format.Fill.ForeColor.RGB = Color(i)
                ' データラベル表示。
                .HasDataLabel = True
                ' 表示するのは値。
                .DataLabel.ShowValue = True
                ' 表示する場所は棒グラフの上。
                .DataLabel.Position = xlLabelPositionOutsideEnd
            End With
        Next
End Sub

↓ 結果がこちら。

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

参考まで。

VBA100本ノック 36本目：列の並べ替え

Excel VBA 100本ノック

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

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

（　）内の数字で並べ替えるわけだが、（　）以外の表記に一貫性がない。
従って、単純な並び替えでは上手くいかなそうだ。

ということで今回は、正規表現を用いて一旦数字だけを抽出し、この情報を
元に並び替えることとした。

Sub VBA_100Knock_36()
    ' ( )内の数字を正規表現で抽出。
    Dim myReg As VBScript_RegExp_55.RegExp
    Set myReg = New VBScript_RegExp_55.RegExp
        myReg.Pattern = "\((\d+)\)"
    Dim MC As VBScript_RegExp_55.MatchCollection
        
    Dim arr As Variant
        arr = Range("A1").CurrentRegion
    
    ' ラベル行の（）内の数字を、ラベル文字先頭に表示。
    ' 桁数を揃えるため、書式「K000」にしている。
    ' Kは、Sort KeyのK。
    Dim i As Long
        For i = 1 To UBound(arr, 2)
            If myReg.Test(arr(1, i)) Then
                Set MC = myReg.Execute(arr(1, i))
                arr(1, i) = Format(MC(0).SubMatches(0), "K000") & _
                            "_" & arr(1, i)
            End If
        Next
    
    ' 元のデータを一旦クリアし、縦横変換して貼り付け。
        Range("A1").CurrentRegion.ClearContents
        Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)) = _
                                    WorksheetFunction.Transpose(arr)
    
    ' 一列目でソート。
    Dim Sh As Worksheet: Set Sh = ActiveSheet
        Sh.Sort.SortFields.Clear
        Sh.Sort.SortFields.Add Key:=Range("A1")
        With Sh.Sort
            .SetRange Range("A1").CurrentRegion
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
    ' 配列に格納して、もう一度縦横変換。
        arr = Sh.Range("A1").CurrentRegion
        arr = WorksheetFunction.Transpose(arr)
    
    ' ラベルに追加した、ソート用の「K000」を除去。
    Dim Temp As Variant
        For i = 1 To UBound(arr, 2)
            Temp = Split(arr(1, i), "_")
            If UBound(Temp) <> 0 Then
                arr(1, i) = Temp(1)
            End If
        Next
    
    ' 並べ替えに使用したデータをクリアして、並べ替え後の配列を貼り付け。
        Range("A1").CurrentRegion.ClearContents
        Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

↓ 結果がこちら。

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

参考まで。

輪唱で例えてみた話

試してみた

みなさんご存じの輪唱。例えばこちらの「静かな湖畔」。
※音が出るのでご注意ください。
www.youtube.com

前の人が二小節歌ったところで、次の人が最初から歌い始める。
小学生の時に、多くの人が音楽の授業で習ったことと思う。

「静かな湖畔の森のかげから」が二小節であって、これを歌うのに約４秒かかったとしよう。今回は更に特別に、１番を延々と繰り返し歌うとする。

すると、Ａさんの歌う歌詞と時間の関係はこうなる（図１）

だが実際は輪唱なのだから、こんな感じで複数の人が歌うことだろう（図２）




※カッコウを「郭公」と漢字で書いたのは、カタカナだと入りきらなかったから。

ここで例えばＣさんに着目する。歌い始めてから４０秒後に、Ｃさんはどの小節を歌ったところだろう？様々な考え方があると思うが、ここではＡさんとの「ずれ」に着目する。Ｃさんは、Ａさんと８秒ずれているわけだから、ＡさんはＣさんより８秒前に、つまり３２秒のときに同じところを歌っているはずだ。なお、Ａさんの歌う歌詞と時間の関係は、すでに図１で求まっている。このことから、Ｃさんは「もう起きちゃいかがと郭公が鳴く」を歌っていたことが判るわけだ。

以上の話は、物理で習う「波の式」を、何とか長男（高２）に説明しようと考えたもの。
y=Asin\displaystyle{\frac{2π}T}(t-\frac{x}v)
※図１　ｙ－ｔグラフ
※図２　ｙ－ｘグラフ

昨日咄嗟に考えた例えなので、厳密には違うと言われればそれまでだが、
理解の一助になれば幸いです。

※正しく知りたい方は、例えば ↓ こちらをご参照ください。
youtu.be

ご参考まで。

遠出の前の、情報収集の大切さ

失敗談

先週金曜日（8/5）の朝７時、京都に向けて出発した。前日の大雨はニュースなどで知っていたが、何の根拠もなく「大丈夫だろう」と考えて、あまり情報収集していなかった。

しかし北陸道に乗りしばらくして、武生 ～ 敦賀 間が「大雨により」通行止めになったことを知る。大雨により？まだ、あまり深刻には捉えられていなかった。

そして石川県を過ぎ、福井ＩＣを過ぎた頃、事態のやばさに気づく。まず通行止めが解除されないまま、武生で高速から降りるだけで１時間の渋滞。直前のサービスエリアでトイレ休憩を取っておいてよかった。

武生 ～ 敦賀間が通行止めなら、下道で敦賀まで抜けるしかない。そう考えて敦賀ＩＣを目指すも、氾濫寸前の日野川を目の当たりにして身の危険を感じた。

山を越えようとするも、ことごとく通行止め。警察の方からは、「土砂崩れで通れない」と説明が。これはひょっとして、京都にたどり着けない？

５万円近いホテルのキャンセル料を払って、今回は諦めるか。それとも、迂回ルートを探すか。家族で相談の結果、東海北陸自動車道で京都を目指すことになった。このとき既に、13時を回っていた。

最終的に京都に到着したのが20時頃。実に13時間の長時間運転となった。情報収集していれば、最初から東海北陸自動車道を行く選択もありえたかもしれない。

↓ 予定していた旅程

↓ 実際の旅程

今回の教訓

  1. 道路交通情報や災害情報は、事前にしっかり押さえておこう。
  2. 工事などによる車線減少は、長時間の渋滞にはまる恐れあり。
    一旦高速を降りて下道で迂回した方が、時間的には速い場合あり？

以上、ご参考まで。

VBA100本ノック 35本目：条件付き書式

Excel VBA 100本ノック

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

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

行や列のコピー等と共に条件付き書式が増殖するのは、もはや宿命と言って
良いほど、定期的に遭遇する問題だと思う。

また、VBAで条件付き書式を設定することの是非についても、自分の中で
肯定派と否定派が定期的に順位を入れ替えている。

それはさておき、今回作成したのがこちら。

Sub VBA_100Knock_35()
    Dim TargetRange As Range
    Set TargetRange = Intersect(Range("B2").CurrentRegion, Union(Columns("E"), Columns("G")))

        Cells.FormatConditions.Delete
        
        ' 一つ目の条件付き書式。
        TargetRange.FormatConditions.Add Type:=xlExpression, Formula1:="=E2<1"
        TargetRange.FormatConditions(TargetRange.FormatConditions.Count).SetFirstPriority
        
        With TargetRange.FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        TargetRange.FormatConditions(1).StopIfTrue = False

        ' 二つ目の条件付き書式。
        ' FormatContiions(1)としたことで、先に設定した条件付き書式が
        ' 二番目に繰り下がっている。
        TargetRange.FormatConditions.Add Type:=xlExpression, Formula1:="=E2<0.9"
        TargetRange.FormatConditions(TargetRange.FormatConditions.Count).SetFirstPriority
        With TargetRange.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        TargetRange.FormatConditions(1).StopIfTrue = True
        
End Sub

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

参考まで。

Excelで連立二元一次方程式を解いてみた

Excel 高校数学 中学数学

長男の勉強を切っ掛けに、高校数学を少しずつ再学習している。
今回はこれを応用して、Excelで連立二元一次方程式を解いてみた。

問題：
鶴と亀がいます。鶴と亀の頭数の合計は14です。
鶴の足と亀の足の合計は、40本です。
鶴と亀は、それぞれ何羽・何匹でしょうか。

中学校で習う連立方程式では、例えばこのように式を立てる。
鶴の数をｘ、亀の数をｙとおいて、
x+y=14
2x+4y=40
これを代入法なり加減法で解くわけだが、Excelだと何れの方法もやりにくい。

そこで今回は、行列を用いることにした。
manabitimes.jp

まず、先の連立方程式を行列で表すと、次のようになる。

 \begin{pmatrix}1&1\\2&4\end{pmatrix}\begin{pmatrix}x\\y\end{pmatrix}=\begin{pmatrix}14\\40\end{pmatrix}
これを、先程のリンク先にある逆行列で整理すると、このようになる。
\begin{pmatrix}x\\y\end{pmatrix}={\displaystyle\frac{1}{1×4-1×2}}\begin{pmatrix}4&-1\\-2&1\end{pmatrix}\begin{pmatrix}14\\40\end{pmatrix}
={\displaystyle\frac{1}{2}}\begin{pmatrix}4×14-1×40\\-2×14+1×40\end{pmatrix}={\displaystyle\frac{1}{2}}\begin{pmatrix}16\\12\end{pmatrix}=\begin{pmatrix}8\\6\end{pmatrix}
ということで鶴は８羽、亀は６匹となるわけだが、ここに至るまでの計算がとてもとても面倒くさい。中学生のテストでは、解法として絶対にお勧めできない。

でも、Excelでやるならお勧めできる。

そんな機会がどこにある？と問われると、多く人には無さそうなので、
総じてやっぱりお勧めできないのでした。

参考まで。