結合セルの情報について

Question

画像のような形で結合されたセルの情報を分割して表にする場合は
どのようにすればよいでしょうか。

結合セルの大きさが違う場合や間に空白セルが挟まることもあり難航しています。

下記の結合セルの解除を行ってみましたが、列によってセルの大きさが違うため
上手くいきませんでした。

ご教示いただけると助かります。

Sub UnmergeCellsAndFillValues()
  Dim rng As Range
  
  For Each rng In ActiveSheet.UsedRange
    If rng.MergeCells Then
      With rng.MergeArea
        .UnMerge
        .Value = .Resize(1, 1).Value
      End With
    End If
  Next
End Sub

Comments

[tatsu99]

結合セルを解除するのではなく、結合セルに書かれた情報を読み取り、別シートに書き出すようにしてはいかがでしょうか。

[tosi]

結合セルの値は先頭セルに入っています。
2行に見えるのは改行されているだけです。

Answer 1

そのセルがそのセルを含む結合された範囲の1番目かをチェックし、
1番目以外は処理を飛ばします。
そして、値が空白かどうかはIsEmpty関数でチェックします。

Sub test()
    Dim Rng As Range
    Dim c As Range
    Dim r(1 To 7) As Variant
    Dim v1 As Variant
    Dim v2 As Variant
    Dim i As Long
    
    With ActiveSheet.Range("A1").CurrentRegion
        Set Rng = Intersect(.Cells, .Offset(1, 1))
    End With
    
    For Each c In Rng
        If c.Address = c.MergeArea(1).Address Then
            If IsEmpty(c.Value) = False Then
                i = i + 1
                v1 = Split(c.Value, vbLf)
                v2 = Split(v1(1), "(")
                
                r(1) = Intersect(c.EntireColumn, Rng.Rows(0)).Value
                r(2) = Intersect(c.EntireRow, Rng.Columns(0)).Value
                r(3) = Intersect(c(c.MergeArea.Rows.Count + 1, 1).EntireRow, Rng.Columns(0)).Value
                r(4) = v1(0)
                r(5) = v1(2)
                r(6) = v2(0)
                r(7) = Val(v2(1))
                ActiveSheet.Range("E4").Cells(i, 1).Resize(, 7).Value = r
            End If
        End If
    Next
End Sub

Answer 2

MergeCellsプロパティでそのセルが結合されいるかどうか、
MergeAreaプロパティで結合されてるセル範囲を取得できます。
それを利用してコードを組めばいいでしょう。

Office TANAKA - Excel VBA Tips[結合セルを調べる]

---

あれからサンプルを作成して試してみたら、.Offset(1) で結合セルの場合でも次のセルへ移動しますね。
(A2~A6 が結合セルの場合、Range("A2").Offset(1) で Range("A7") へ移動する)

ということで、下記のようなコードで結合セルでも順に最後まで移動しながらデータを取得できます。

Sub Test()
    Dim endRow As Long
    endRow = Cells(Rows.Count, 2).End(xlUp).Row

    Dim curRng As Range
    Set curRng = Cells(2, 2)
    
    Do Until curRng.Row > endRow
        If curRng.Value <> "" Then
            Debug.Print "開始："; curRng.Offset(0, -1).Text
            Debug.Print "終了："; curRng.Offset(1, -1).Text
            Debug.Print curRng.Text
        End If
        Set curRng = curRng.Offset(1) ’次のセルへ移動（結合セルでもOK）
    Loop
End Sub

B列のみ順に移動していってイミディエイトに出力する例ですので、これをもとに改良してご希望の出力になるようにしてください。