2022-05-30

久しぶりの加法定理

Excel 高校数学

５月の連休中に長男（高２）の数学で、久しぶりに加法定理と再会した。

$sin(α±β)=sinαcosβ±cosαsinβ$
$cos(α±β)=cosαcosβ∓sinαsinβ$

これを用いると、↓のようなお絵かきマクロに必要な値を求めることができる。

点Ｐを中心に点Ｑ1を $β°$ 回転させたときの点Ｑ2の座標。

まず、基本に立ち返ってみる。下図においては、定義により次が成立する。

$\dfrac{x}{r}=cosθ, 　\dfrac{y}{r}=sinθ$
両辺に $r$ を掛けて、
$x=rcosθ,　y=rsinθ$

では、この場合はどうだろう。

Q1がｘ軸からα回転したものであるとき、Q2はｘ軸からα＋β回転するわけだから、
先程の結果から考えると以下が成立する。
$qx_{\mathrm{2}}=px+rcos(α+β),　qy_{\mathrm{2}}=py+rsin(α+β)$

ここで加法定理を用いると、次のように変形できる。
$qx_{\mathrm{2}}=px+rcos(α+β)=px+rcosαcosβ-rsinαsinβ=px+dxcosβ-dysinβ$
$qy_{\mathrm{2}}=py+rsin(α+β)=py+rsinαcosβ+rcosαsinβ=py+dycosβ+dxsinβ$
角度αを求めなくとも、
$rcosα=dx,　rsinα=dy$
であるから、加法定理の中身からαに関する部分が消えて、そこそこシンプルに
なってくれるわけで。

ということで、例えば ↓ こんな具体例で、Q2の座標を求めてみよう。

結果がこちら。多分、合ってると思う。

参考まで。

2022-05-23

組合せ表を作る　２．重複を認めない

Excel VBA 試してみた

先日は、部品１～部品４が各々ＡからＣの何れかの値を取り得るとき、
その全ての組合せ表を作ることに挑戦した。
infoment.hatenablog.com

今回は、Ａ～ＣではなくＡ～Ｄの何れかの値を取るものとして、
それらが重複しない場合のみの組合せ表を作成してみよう。

重複しないのだから、例えば
・ＡＡＡＡ
・ＡＡＢＣ
のように、同じ文字が二つ以上含まれるものは除外される。
・ＡＢＣＤ
・ＢＣＡＤ
のように、全ての文字が含まれる場合のみ残るわけだ。

重複を許さないということで、お馴染みの辞書（連想配列）を用いて
マクロで作成するなら、例えばこんな感じだろうか。

Sub Sample()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim arr(0 To 4 ^ 4, 1 To 5)
    Dim counter As Long
    Dim Dict As Scripting.Dictionary
    Set Dict = New Dictionary
    
        ' ラベル行データ作成。
        arr(0, 1) = "No."
        arr(0, 2) = "部品1"
        arr(0, 3) = "部品2"
        arr(0, 4) = "部品3"
        arr(0, 5) = "部品4"
        
        ' ボディ部のデータ作成。
        ' "A"が、Chr関数でChr(65)であることを利用している。
        For i = 1 To 4
            For j = 1 To 4
                For k = 1 To 4
                    For l = 1 To 4
                        ' i～lを辞書に登録し、重複がない場合のみ登録する。
                        Dict(i) = i
                        Dict(j) = j
                        Dict(k) = k
                        Dict(l) = l
                        If UBound(Dict.Keys) = 3 Then
                            counter = counter + 1
                            arr(counter, 1) = counter
                            arr(counter, 2) = Chr(i + 64)
                            arr(counter, 3) = Chr(j + 64)
                            arr(counter, 4) = Chr(k + 64)
                            arr(counter, 5) = Chr(l + 64)
                        End If
                        Dict.RemoveAll
        Next l, k, j, i
        
        ' 値貼り付け。
        Range("A1").Resize(counter + 1, 5) = arr
End Sub

今回は重複チェックで辞書を使っているので、前回よりさらに手間が増えている。
※きっと、もっとスマートな方法があるに違いない。

そこで前回同様、関数で対応することを考えてみた。
※しつこいようだが恐らく、これも既に広く知られている手法と思う。

まず前回同様、関数で組合せ表を作成する。

ここにもう一列追加して、部品１～部品４までの文字種類数を数える。
なお、SUMPRODUCT関数とCOUNTIF関数を組み合わせたこの方法は、
様々なサイトで紹介されているので、そちらを参照してほしい。

あとは、文字種類数が４のものでフィルタをかければよい。

前回に増して万人受けしないものが出来てしまったが、やはり個人的に
嫌いではない。もし採用され場合は、時と場合と各位のお好みで。

参考まで。

2022-05-21

組合せ表を作る　１．すべての組合せを考える

Excel VBA 試してみた

詳細は割愛するが、仕事で３つの装置の部品を組み合わせて何某か評価することとなった。評価するための組合せ表が必要となったので、作ってみた。
エッセンスのみ、一部だけ表すと、こんな感じだ。

これをマクロで作成するなら、例えばこんな感じだろうか。

Sub Sample()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim arr(0 To 3 ^ 4, 1 To 5)
    Dim counter As Long
    
        ' ラベル行データ作成。
        arr(0, 1) = "No."
        arr(0, 2) = "部品1"
        arr(0, 3) = "部品2"
        arr(0, 4) = "部品3"
        arr(0, 5) = "部品4"
        
        ' ボディ部のデータ作成。
        ' "A"が、Chr関数でChr(65)であることを利用している。
        For i = 1 To 3
            For j = 1 To 3
                For k = 1 To 3
                    For l = 1 To 3
                        counter = counter + 1
                        arr(counter, 1) = counter
                        arr(counter, 2) = Chr(i + 64)
                        arr(counter, 3) = Chr(j + 64)
                        arr(counter, 4) = Chr(k + 64)
                        arr(counter, 5) = Chr(l + 64)
        Next l, k, j, i
        
        ' 値貼り付け。
        Range("A1").Resize(3 ^ 4 + 1, 5) = arr
End Sub

今回の例でいえば、部品数が４つなので、４重ループとなっている。
しかしこの数がもっと増えた場合は、マクロを組むのも面倒くさい。

そこで、関数で対応することを考えてみた。
※言うまでもないことだが恐らく、既に広く知られている手法と思う。

まず表に一列追加して、通し番号を三進数に変換する（BASE関数を利用）。

部品数が４つあるので、４桁にしたい。そこでさらに、数字に変えて４桁表示にしよう。

次に、部品のセルに、三進数の各桁の数字を表示してみる。２列目が１文字目、
３列目が２文字目・・・という規則性があるので、Ａ～Ｃを表示するセルの式は
全て共通で対応できる。

こうすると、０～２が順番に登場する組合せ表が出来上がるわけだ。数字は

0 ⇒ Ａ
1 ⇒ Ｂ
2 ⇒ Ｃ

に対応している。Char関数で変換しよう。

結果として無事、組合せ表を作成することができた。
登場した数式は、作業用に三進数で表した列と、Ａ～Ｃを表示する列の２つのみ。式の数という意味では、かなりシンプルになったと思う。

ただし万人受けするかといえば、疑問符が付く（個人的には結構好きかも）。
ということで、もし採用される場合は、時と場合と各位のお好みで。

参考まで。

2022-05-12

１から３０までを１２列で並べる

Excel 試してみた

前回は、名簿を段組みにする100本ノックに挑戦した。
infoment.hatenablog.com
今回は、段組みについてのお話。

例えば、１から３０までの数字を、１２列で折り返して並べたいとする。
こんな感じだ。

このとき、３０番目の数が何行何列目に来るか知るには、どのような方法が
あるだろうか。やってみた。

1. IF関数を駆使する。

行・・・数が１なら１行目。列数が１なら、前の列数に１を足す。
　　　　それ以外は、一つ前と同じ。
列・・・数が１なら１列目。前の列数が１２なら、１に戻る。
　　　　それ以外は、一つ前に１を足す。

実際、式をセットするとこうなる。

テーブルに式をセットしたので、だいぶん複雑になってしまった。理屈としては
一番簡単だが、式の可読性という点では今一つか。

2. 余りを利用する。

12で割ったときの余りで、列数を求める。ただし、12列目は余りが０になって
しまい都合が悪いので、１引いた値を１２で割った余りをもとめ、それに１を
足し直すことで列数を求める。

行数は、１２で割った商を小数点第一位で切り上げることで求める。
実際、式をセットするとこうなる。

式としてはかなりシンプルになった。ただし、
「１引いた値を１２で割って、余りに１を足す」
の部分が、ちょっと難しいかもしれない。

3. １２進数にする。

１から１２が繰り返し現れるわけだから、１２進数の一桁目が列数で、
二桁目以上が行数になる。１１の一桁目がＡに、１２の一桁目がＢに
なるので、結構ややこしい。なお、各変換には以下の関数を用いる。

１０進数 ⇒ １２進数　BASE関数
１２進数 ⇒ １０進数　DECIMAL関数

実際、式をセットするとこうなる。

今回の中でもっとも複雑な式となっていて、しかも一番難解なものに
なってしまった。

でも、嫌いじゃないかも。実際の場面でどの方式を採用するかは、
時と場合と、各位のお好みで。

参考まで。

2022-05-05

VBA100本ノック 30本目：名札作成（段組み）

Excel VBA 100本ノック

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

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

名札が二列になっているので、改行することに２進法を使えないか？と
ちょっと考えてみた。今回は、考えてみただけで実装はしていない。

Sub VBA_100Knock_030()
    Dim Ws(ShName.en名簿 To ShName.en名札) As Worksheet
    Set Ws(ShName.en名簿) = Worksheets("名簿")
    Set Ws(ShName.en名札) = Worksheets("名札")
    
    ' 名簿データを一旦配列に格納し、名札用に並び替える。
    Dim SrcArray As Variant
        SrcArray = Range(Ws(ShName.en名簿).Range("B2"), _
            Ws(ShName.en名簿).Range("B2").CurrentRegion. _
                SpecialCells(xlCellTypeLastCell))
                
    Dim DstArray() As Variant
    ReDim DstArray(1 To 2 * WorksheetFunction.RoundUp(UBound(SrcArray) / 2, 0), _
                   1 To 2)
        
    Dim i As Long
    Dim RowIndex As Long
    Dim ColumnIndex As Long
        For i = 1 To UBound(SrcArray)
            RowIndex = 2 * WorksheetFunction.RoundUp(i / 2, 0) - 1
            
            ' データが偶数行か奇数行かで、一列目と二列目を判別する。
            If WorksheetFunction.IsOdd(i) Then
                ColumnIndex = 1
            Else
                ColumnIndex = 2
            End If
            
            DstArray(RowIndex, ColumnIndex) = SrcArray(i, 1)
            DstArray(RowIndex + 1, ColumnIndex) = SrcArray(i, 2)
        Next
        
        Application.ScreenUpdating = False
        
        Ws(ShName.en名札).Range("A1").Resize(UBound(DstArray), 2) = DstArray
        ' 名札の書式コピー＆ペースト。
        Ws(ShName.en名札).Rows("1:2").Copy
        Ws(ShName.en名札).Rows("1:" & UBound(DstArray)).PasteSpecial Paste:=xlPasteFormats
        Ws(ShName.en名札).Range("A1").Select
        
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
End Sub

今回も毎度のように、汎用性を持たせようとして、冗長な作りになって
しまった。実行した結果がこちら。

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

参考まで。

2022-04-23

VBA100本ノック 29本目：画像の挿入

Excel VBA 100本ノック

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

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

選択する方法は、先日も使用した「Application.FileDialog」を採用。
「選択できる拡張子は適当に」とのことだったので、今回は「*.jpg」とした。

Sub VBA_100Knock_029()
    ' 画像を挿入するセル。
    Dim TargetCell As Range
    Set TargetCell = ActiveCell
    ' 挿入する画像のファイルパス。
    Dim FilePath As String
        With Application.FileDialog(msoFileDialogFilePicker)
            ' ファイル選択ダイアログ表示。
            .Show
            ' ファイルの複数選択不可。
            .AllowMultiSelect = False
            ' ダイアログタイトル。
            .Title = "画像データ選択"
            ' 選択フィルタ。
            .Filters.Clear
            .Filters.Add "画像データ", "*.jpg"
            FilePath = .SelectedItems(1)
        End With
        
    ' 挿入する画像。
    Dim Drawing As Picture
    Set Drawing = ActiveSheet.Pictures.Insert(FilePath)
        ' 画像の縦横比を固定。
        Drawing.ShapeRange.LockAspectRatio = msoTrue
    
    ' 画像とセル、各々の縦横比を取得。
    ' どちらが「より縦長か？」を比較して、挿入する画像サイズをセルの
    ' 幅に合わせるか高さに合わせるか決定する。
    Dim AspectRatio(1) As Double
        AspectRatio(0) = TargetCell.Height / TargetCell.Width
        AspectRatio(1) = Drawing.Height / Drawing.Width
        
    ' セルの方が縦長なら、画像はセルの横幅に合わせる。
    If AspectRatio(0) >= AspectRatio(1) Then
        Drawing.ShapeRange.ScaleWidth TargetCell.Width / Drawing.Width, msoTrue
        ' 高さ方向の位置修正（セルの中央に配置）。
        ' 幅方向は、セルと同サイズのため調整不要。
        Drawing.Top = TargetCell.Top + (TargetCell.Height - Drawing.Height) / 2
    Else
        Drawing.ShapeRange.ScaleHeight TargetCell.Height / Drawing.Height, msoTrue
        ' 幅方向の位置修正（セルの中央に配置）。
        ' 鷹さ方向は、セルと同サイズのため調整不要。
        Drawing.Left = TargetCell.Left + (TargetCell.Width - Drawing.Width) / 2
    End If
End Sub

何を基準に、どのように拡大または縮小すればよいか、少し悩んでしまった。
実行した結果がこちら。

ちなみにこの画像は、数年前に家族で訪れた「眼目山立山寺」で撮った写真。
樹齢400年の栂並木が素晴らしく、機会があればもう一度訪れてみたい。
youtu.be

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

参考まで。

2022-04-19

VBA100本ノック 28本目：シートをブックに分割

Excel VBA 100本ノック

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

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

実際の業務でも、似たようなケースがあると思う。フォルダの存在確認は、
個人的にはFileSystemObjectのFolderExistsが直感的に理解しやすいので多用
している。読んで字のごとく、そのまんまだし。

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

Sub VBA_100Knock_028()
    ' Microsoft Scripting Runtime参照済み。
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    ' ワークシートのループ用変数。
    Dim Ws As Worksheet
    ' 部署名。
    Dim PartName As String
    
    Dim FileName As String
    Dim FolderName As String
    Dim FolderPath As String
    Dim FilePath As String
    Dim Wb As Workbook
    
        Application.ScreenUpdating = False
        
        For Each Ws In Worksheets
            ' 「部署名_人の名前」のシート名でないと成立しない。
            PartName = Split(Ws.Name, "_")(0)
            FolderPath = ThisWorkbook.Path & "\" & PartName
            If Not FSO.FolderExists(FolderPath) Then
                MkDir FolderPath
            End If
            
            On Error Resume Next
            FileName = Split(Ws.Name, "_")(1)
            If Err.Number = 0 Then
                FilePath = FolderPath & "\" & FileName
                Ws.Copy
                Set Wb = ActiveWorkbook
                    Wb.SaveAs FilePath, xlOpenXMLWorkbook
                    Wb.Close False
            End If
            On Error GoTo 0
        Next
        
        Application.ScreenUpdating = True
End Sub

ファイル名やパスをいちいち変数に入れており、これを冗長と感じる
人も居るかもしれない。個人的に、誰かに引き継ぐことを前提に作る
場合は、多少くどいと思われても、上記のような作り方にすることが
多いかも。

実行した結果がこちら。

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

参考まで。