takayukisの日記 このページをアンテナに追加 RSSフィード

2018.05.11(金)

[]VBA: 表を折り返す

データベースからコピーしたデータのような横に長い選択範囲を指定した列数になるように折り返します。

選択範囲の下に行を挿入して折り返される部分をコピーします(削除はしません)。

例。5列を指定した場合。◆などはセルを表します。

◆◆◆◆◆■■■■■
◇◇◇◇◇□□□□□

◆◆◆◆◆■■■■■
◇◇◇◇◇□□□□□
■■■■■
□□□□□

ソースコード

Sub 表を折り返す()
    Dim 選択範囲 As Range
    Set 選択範囲 = Selection
        Dim 行数 As Long
    行数 = 選択範囲.Rows.Count
    Dim 列数 As Long
    列数 = 選択範囲.Columns.Count

    Dim 最初の行番号 As Long
    最初の行番号 = 選択範囲.row
    Dim 列番号 As Long
    列番号 = 選択範囲.Column

    Dim 折り返しの列数str As String
    折り返しの列数str = InputBox(prompt:="折り返しの列数")
    If 折り返しの列数str = "" Then
        Exit Sub
    End If
    Dim 折り返しの列数 As Long
    折り返しの列数 = Val(折り返しの列数str)
    If 折り返しの列数 = 0 Then
        Exit Sub
    End If
        Dim 折り返し回数 As Long
    折り返し回数 = 列数 / 折り返しの列数
    Dim 余り As Long
    余り = 列数 Mod 折り返しの列数
    If 余り <> 0 Then
        折り返し回数 = 折り返し回数 + 1
    End If
    Dim 挿入行数 As Long
    挿入行数 = (折り返し回数 - 1) * 行数
        Dim 挿入開始行番号 As Long
    挿入開始行番号 = 最初の行番号 + 行数
    Dim 挿入終了行番号 As Long
    挿入終了行番号 = 挿入開始行番号 + 挿入行数 - 1
    Range(挿入開始行番号 & ":" & 挿入終了行番号).Insert
    'コピー
    Dim r As Long
    Dim c As Long
    Dim r2 As Long
    Dim c2 As Long
    Dim srcR As Long
    Dim srcC As Long
    Dim dstR As Long
    Dim dstC As Long
    Dim シート As Worksheet
    Set シート = ActiveSheet
        For c = 折り返しの列数 To 列数 - 1
        For r = 0 To 行数 - 1
            c2 = c Mod 折り返しの列数
            r2 = r + Int(c / 折り返しの列数) * 行数
            srcC = 列番号 + c
            srcR = 最初の行番号 + r
            dstC = 列番号 + c2
            dstR = 最初の行番号 + r2
            'Debug.Print c&; "," & r & "  -> " & c2&; "," & r2 & "   " & _
            '    srcC&; "," & srcR & "  -> " & dstC&; "," & dstR & "   " & _
            '    シート.Range(Cells(srcR, srcC), Cells(srcR, srcC)).Value & _
            '    シート.Range(Cells(dstR, dstC), Cells(dstR, dstC)).Value
            シート.Range(Cells(dstR, dstC), Cells(dstR, dstC)).Value = シート.Range(Cells(srcR, srcC), Cells(srcR, srcC)).Value
        Next
    Next
End Sub

はてなユーザーのみコメントできます。はてなへログインもしくは新規登録をおこなってください。

トラックバック - http://d.hatena.ne.jp/takayukis/20180511/1526047679