今回は前回からの続きでちょっと扱いづらい表を転記するということについて考えていきます。
今回は4列で3行が1つのデータという風になっています。
よく縦持ちとかマトリックスとか、呼び方様々なんですけれども、データベースの表形式ではない表ですね。
見るための表として作成されたものです。時間があって担当があって、これは介護病棟か、介護施設などの担当者の表です。

時間が変わると担当が変わるので、9時にAならばこちらの11時にB、15時にCという風に1行1データにしたいわけです。

考え方ですが、下の行から見ていきましょう。一番下の行がもし、上と同じだったらば、その行の時間と担当は、一つ上に持ってっていいんだよということにします。

そして空のデータをですね。空なんですけれども上にに持っていきます。 そして2つ持って行ったら一番下の行は消してしまう。

コードに表すと以下の図のようになります。

もし、患者名が同じで、部屋番
号も同じだったら、
If Cells(行, 2) = Cells(行 - 1, 2) And Cells(行, 1) = Cells(行 - 1, 1) Then
その時は、１件のデータとみなされるので、データを移動します。
For 列 = 3 To 6
Cells(行 - 1, 列 + 2) = Cells(行, 列)
Next 列

データの列移動は3列から6列までの４列に対して行います。
For 列 = 3 To 6
データは右から左に入ります。元のデータCells(行, 列)は、行は一つ上、列は２つ左方向のセル、Cells(行 - 1, 列 + 2) に入ります。
Cells(行 - 1, 列 + 2) = Cells(行, 列)

コード全体は以下のようになります。

Sub データベース型の表へ変換()
    Dim lastRow As Long, 行 As Long, 列 As Long
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For 行 = lastRow To 2 Step -1
        If Cells(行, 2) = Cells(行 - 1, 2) And Cells(行, 1) = Cells(行 - 1, 1) Then
        
            For 列 = 3 To 6
                Cells(行 - 1, 列 + 2) = Cells(行, 列)
            Next 列
            Rows(行).Delete
        End If
    Next 行
End Sub

コードを実行すると、１件が３行４列のデータを１件１行のデータに整形することができました。