依頼を受けたので、VBAほぼ書いたことないですが、グーグル先生の力を借りて書いてみました。
作成したxlsmファイルはこちら
やりたいことは下記のように、一つのシートに週単位(下記だと2カラム1セット)などでテーブルがあるときに、
下記のようなコードでできますた。(ツッコミどころ満載かもしれませんが参考まで。)
shrink_column.vb
Sub shrink_colums()
' ---------- 要設定ゾーン Start ----------
NUM_COL_SET = 2 ' 2列1セット
HEADER_OFFSET = 1 ' ヘッダ行の行数
FROM_SHEET_NAME = "Sheet1" ' コピー元のシート名
TO_SHEET_NAME = "ColumnShrinked" ' コピー先のシート名
' ---------- 要設定ゾーン End ----------
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = TO_SHEET_NAME
Worksheets(FROM_SHEET_NAME).Activate
num_col = Cells(HEADER_OFFSET, 1).End(xlToRight).Column
Worksheets(FROM_SHEET_NAME).Range(Cells(HEADER_OFFSET,1), Cells(HEADER_OFFSET, NUM_COL_SET)).Copy Worksheets(TO_SHEET_NAME).Cells(HEADER_OFFSET, 1)
current_bottom_row = HEADER_OFFSET
Dim x As Integer
For x = 1 To num_col Step NUM_COL_SET
num_row = Cells(HEADER_OFFSET+1, x).End(xlDown).Row - HEADER_OFFSET
Worksheets(FROM_SHEET_NAME).Range(Cells(HEADER_OFFSET+1, x), Cells(HEADER_OFFSET+num_row, x+NUM_COL_SET-1)).Copy Worksheets(TO_SHEET_NAME).Cells(current_bottom_row+1, 1)
current_bottom_row = current_bottom_row + num_row
Next x
MsgBox "Finished!!! Result Sheet Name is " & TO_SHEET_NAME
Worksheets(TO_SHEET_NAME).Activate
End Sub
macのエクセルを使っているが、エディタが強くない。atomでpluginいれて書きますた。やっぱりatom使いやすい。