セル結合判定

投稿者 : じょんとらぼるた     投稿日時 : 2025/04/18(Fri) 00:33:45     OS : 未指定     EXCEL : 未指定

---

すいません教えてください。
例えば下記画像のように、A列とD列の日付が一致したら、B列をループし、セルが結合されている場合のセルの値が2の場合は値を1/2し、転記先（E列）に1/2した値を転記する。
セルが結合されている場合のセルの値が1の場合は値をそのまま、転記先（E列）に転記する。
通常のセルはセルの値をそのまま転記先（E列）に転記する。

画像：https://ibb.co/xt8VyxfB

このようなことを行うvbaで行うことは可能なのでしょうか？
もし可能でしたらコードを教えていただきたいです。
vba詳しい方いらっしゃれば何卒よろしくお願いします。

投稿者 : 例えば     投稿日時 : 2025/04/18(Fri) 07:02:24

---

とりあえず以下でどうですか？

添付画像の8月13日は、E14は１ですよね？
（セルが結合されている場合のセルの値が1の場合は値をそのまま、転記先（E列）に転記する。）

Sub 転記処理()

    Dim lastRowA As Long, lastRowD As Long
    Dim i As Long, j As Long
    Dim matchDate As Date
    Dim bValue As Variant
    Dim isMerged As Boolean
    Dim mergedRows As Long

    ' 最終行の取得
    lastRowA = Cells(Rows.Count, "A").End(xlUp).Row
    lastRowD = Cells(Rows.Count, "D").End(xlUp).Row

    ' D列をループ
    For i = 1 To lastRowD
        If IsDate(Cells(i, "D").Value) Then
            matchDate = Cells(i, "D").Value

            ' A列をループして一致する日付を探す
            For j = 1 To lastRowA
                If IsDate(Cells(j, "A").Value) Then
                    If Cells(j, "A").Value = matchDate Then

                        ' B列の値取得
                        With Cells(j, "B")
                            bValue = .Value
                            isMerged = .MergeCells

                            ' セルが結合されている場合の処理
                            If isMerged Then
                                mergedRows = .MergeArea.Rows.Count

                                ' 値が2の場合は1/2して転記
                                If bValue = 2 Then
                                    Cells(i, "E").Value = bValue / 2
                                ' 値が1の場合はそのまま転記
                                ElseIf bValue = 1 Then
                                    Cells(i, "E").Value = bValue
                                ' その他の値はそのまま
                                Else
                                    Cells(i, "E").Value = bValue
                                End If

                            ' 結合されていない場合はそのまま
                            Else
                                Cells(i, "E").Value = bValue
                            End If
                        End With
                        Exit For ' 一致が見つかれば次のD行へ
                    End If
                End If
            Next j
        End If
    Next i

    MsgBox "転記が完了しました！"

End Sub

投稿者 : てらてら     投稿日時 : 2025/04/18(Fri) 07:13:09

---

こんにちは。

結合セルは、Cells(***, ***).MergeCells で判断できます。
参考にしてみてください。
(ちょっ時間がないので見直してないです。間違ってたらごめんなさい。)

Sub macro()
    Dim i As Long, j As Long, v As Long
    Dim myDay
    Dim b As Boolean
    b = False
    
    For i = 2 To ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
        myDay = Cells(i, "A")
        If Cells(i, "B").MergeCells = True Then
            If b = False Then
                b = True
                v = Cells(i, "B")
                If v = 2 Then v = 1     'セルの値が2の場合は値を1/2 (セルの値が1の場合は値をそのまま)
                For j = 2 To ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
                    If Cells(j, "D") = myDay Then
                        Cells(j, "E") = v
                        Exit For
                    End If
                Next j
            Else
                b = False
            End If
        Else
            b = False
            For j = 2 To ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
                If Cells(j, "D") = myDay Then
                    Cells(j, "E") = Cells(i, "B")
                    Exit For
                End If
            Next j
        End If
    Next i
    
End Sub

投稿者 : ピロリ     投稿日時 : 2025/04/18(Fri) 23:06:59

---

一案です。　参考になれば･･･

Sub Sample()
    Dim i As Long, r As Range
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        Set r = Columns("A").Find(What:=Cells(i, "D"), LookAt:=xlWhole)     '日付の検索
        If Not r Is Nothing Then                            '一致する日付が存在した場合
            If r.Offset(0, 1).MergeCells = True Then        'その右側(B列)がセル結合なら
                Select Case r.Offset(0, 1)
                    Case 1
                        Cells(i, "E") = r.Offset(0, 1)      'その値をE列へ転記
                    Case 2
                        Cells(i, "E") = r.Offset(0, 1) / 2  'その値の1/2をE列へ転記
                    Case Else
                End Select
            Else                                            'セル結合されてないなら
                Cells(i, "E") = r.Offset(0, 1)              'そのままE列へ転記
            End If
        End If
    Next i
End Sub

投稿者 : jindon     投稿日時 : 2025/04/19(Sat) 13:16:18

---

もしB列の同じ日付の行のC列が必ず結合されているなら

Sub test()
    Dim r As Range, c As Range, x
    Set r = [b2].CurrentRegion
    For Each c In [e2].CurrentRegion.Columns(1).Cells
        x = Application.VLookup(c, r, 2, False)
        If IsError(x) Then
            c(, 2) = ""
        ElseIf (x = Empty) + (x < 2) Then
            c(, 2) = x
        Else
            c(, 2) = x / WorksheetFunction.CountIf(r.Columns(1), c)
        End If
    Next
End Sub

投稿者 : じょんとらぼるた     投稿日時 : 2025/04/19(Sat) 19:39:35

---

教えてくださった皆さんありがとうございます。
様々なやり方があるんだなと勉強になりました。
ありがとうございます。