組合せ表を作る 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が順番に登場する組合せ表が出来上がるわけだ。数字は
- 0 ⇒ A
- 1 ⇒ B
- 2 ⇒ C
に対応している。Char関数で変換しよう。
結果として無事、組合せ表を作成することができた。
登場した数式は、作業用に三進数で表した列と、A~Cを表示する列の2つのみ。式の数という意味では、かなりシンプルになったと思う。
ただし万人受けするかといえば、疑問符が付く(個人的には結構好きかも)。
ということで、もし採用される場合は、時と場合と各位のお好みで。
参考まで。
1から30までを12列で並べる
前回は、名簿を段組みにする100本ノックに挑戦した。
infoment.hatenablog.com
今回は、段組みについてのお話。
例えば、1から30までの数字を、12列で折り返して並べたいとする。
こんな感じだ。
このとき、30番目の数が何行何列目に来るか知るには、どのような方法が
あるだろうか。やってみた。
1. IF関数を駆使する。
- 行・・・数が1なら1行目。列数が1なら、前の列数に1を足す。
それ以外は、一つ前と同じ。 - 列・・・数が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
素晴らしい教材を公開いただき、ありがとうございます。
上記リンク先から、問題文を転載。
ハイパーリンク情報を取得するということで、今回はHyperlinksオブジェクト
を使用する(そのまんま)。
docs.microsoft.com
テスト用サンプルとして、Wikipediaのページをコピペしたこちらを準備した。
作成したマクロがこちら。
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
実行した結果がこちら。
※冒頭リンク先の解答例および解説も、ぜひご一読ください。
参考まで。
VBA100本ノック 26本目:ファイル一覧作成
こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。
上記リンク先から、問題文を転載。
ファイル名や更新日時、サイズを取得するということで、今回は
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
実行した結果がこちら。
ダイアログを開いてフォルダを選択というのは、個人的にVBAでは
普段あまりやらないかも。おさらいの意味でも、今回のテーマは勉強
になりました。
※冒頭リンク先の解答例および解説も、ぜひご一読ください。
参考まで。