組合せ表を作る 1.すべての組合せを考える

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

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

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

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

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

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

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

次に、部品のセルに、三進数の各桁の数字を表示してみる。2列目が1文字目、
3列目が2文字目・・・という規則性があるので、A~Cを表示するセルの式は
全て共通で対応できる。

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

  1. 0 ⇒ A
  2. 1 ⇒ B
  3. 2 ⇒ C

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

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

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

参考まで。

1から30までを12列で並べる

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

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

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

1. IF関数を駆使する。

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

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

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

2. 余りを利用する。

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

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

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

3. 12進数にする。

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

  • 10進数 ⇒ 12進数 BASE関数
  • 12進数 ⇒ 10進数 DECIMAL関数

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

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

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

参考まで。

VBA100本ノック 30本目:名札作成(段組み)

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

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

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

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

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

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

参考まで。

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

こちらで公開されている、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

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

参考まで。

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

こちらで公開されている、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

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

実行した結果がこちら。

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

参考まで。

VBA100本ノック 27本目:ハイパーリンクのURL

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

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

ハイパーリンク情報を取得するということで、今回はHyperlinksオブジェクト
を使用する(そのまんま)。
docs.microsoft.com

テスト用サンプルとして、Wikipediaのページをコピペしたこちらを準備した。
f:id:Infoment:20220411232525p:plain

作成したマクロがこちら。

Sub VBA_100Knock_027()
    Dim i As Long
        For i = 1 To 6
            ' ハイパーリンクの存在確認。
            ' ※無いと、次の処理でエラーになる。
            If Cells(i, 1).Hyperlinks.Count <> 0 Then
                Cells(i, 2) = Cells(i, 1).Hyperlinks.Item(1).Address
                Cells(i, 1).Hyperlinks.Delete
            End If
        Next
End Sub

実行した結果がこちら。
f:id:Infoment:20220411232723p:plain

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

参考まで。

VBA100本ノック 26本目:ファイル一覧作成

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

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

ファイル名や更新日時、サイズを取得するということで、今回は
FileSystemObjectを使用することにした。

Sub VBA_100Knock_026()
    'フォルダを選択。
    Dim FolderPath As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            On Error Resume Next
            FolderPath = .SelectedItems(1)
            ' キャンセルが押された場合。
            If Err.Number <> 0 Then Exit Sub
            On Error GoTo 0
        End With
        
    ' Microsoft Scripting Runtime参照設定。
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' 指定フォルダ内のファイル数を取得。
    Dim iMax As Long
        iMax = FSO.GetFolder(FolderPath).Files.Count
        
        If iMax = 0 Then Exit Sub
    
    ' 取得結果を格納するための配列。
    Dim arr() As Variant
    ReDim arr(1 To iMax + 1, 1 To 4)
    ' ラベル情報作成。
        arr(1, 1) = "ファイル一覧"
        arr(1, 2) = "更新日時"
        arr(1, 3) = "サイズ"
        arr(1, 4) = "フルパス"
    
    Dim i As Long: i = 2
    Dim File As Scripting.File
        For Each File In FSO.GetFolder(FolderPath).Files
            arr(i, 1) = File.Name
            arr(i, 2) = File.DateLastModified
            arr(i, 3) = File.Size
            ' 表示する必要は無いが、ハイパーリンク用に格納しておく。
            arr(i, 4) = File.Path
            i = i + 1
        Next
    
    Dim Sh As Worksheet
        On Error Resume Next
    Set Sh = Sheets("ファイル一覧")
        If Err.Number <> 0 Then
            Set Sh = Sheets.Add
            Sh.Name = "ファイル一覧"
        Else
            Sh.Cells.Clear
        End If
        On Error GoTo 0
        
        Range("A1").Resize(iMax + 1, 3) = arr
    
    ' ハイパーリンク設定。Excelファイルのみ。
        For i = 2 To iMax + 1
            If FSO.GetExtensionName(arr(i, 4)) Like "xls?" Then
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
                                           Address:=arr(i, 4), _
                                           TextToDisplay:=arr(i, 1)
            End If
        Next
End Sub

実行した結果がこちら。
f:id:Infoment:20220404205643p:plain

ダイアログを開いてフォルダを選択というのは、個人的にVBAでは
普段あまりやらないかも。おさらいの意味でも、今回のテーマは勉強
になりました。

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

参考まで。