엑셀로 옆에 늘어선 복수 데블을 하나의 세로로 늘어선 테이블로 변환하는 매크로(VBA) 써 보았다

의뢰를 받았으므로, VBA 거의 쓴 적은 없지만, 구글 선생님의 힘을 빌려 써 보았습니다.

만든 xlsm 파일은 여기

하고 싶은 것은 아래와 같이, 하나의 시트에 주 단위(아래라면 2 컬럼 1 세트)등으로 테이블이 있을 때,


아래와 같이 하나의 긴 테이블에 정리하고 싶다.


아래와 같은 코드로 할 수 있었습니다. (츳코미 커녕 가득할지도 모르지만 참고까지.)

shrink_column.vb

Sub shrink_colums()
    ' ---------- 要設定ゾーン Start ----------
    NUM_COL_SET = 2  ' ２列１セット
    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 사용하기 쉽다.