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
今回も毎度のように、汎用性を持たせようとして、冗長な作りになって
しまった。実行した結果がこちら。
※冒頭リンク先の解答例および解説も、ぜひご一読ください。
参考まで。