şarta göre metin birleştirerek bir form oluşturma

[spacebar]

değerli üstadlarım bir sorunuma çözüm bulabilirseniz sevinirim.
şart: A sutununda değeri 1 ise
B sutunundaki metni birleştirerek bir form oluşturmak. yardımlarınız için teşekkürler...

 

[veyselemre]

Sub test()
    Sheets("Sheet1").Select
    Set sf = Sheets("Form")
    sf.Cells.Delete
    sf.Columns(1).ColumnWidth = 80
    satUz = 90 ' Ortalama satırdaki karakter sayısı
    son = Cells(Rows.Count, 1).End(3).Row
    satUz = 90
    For I = 1 To son + 1
        Cells(I, 2).Select
        If Cells(I, 1).Value = 1 Or I > son Then
            If InStr(Cells(I, 2).Text, ".BÖLÜM") Or I > son Then
                sat = sat + 1
                If txt <> "" Then
                    say = Int(Len(txt) / satUz) + 1
                    With sf.Cells(sat, 1).Resize(say, 1)
                        .HorizontalAlignment = xlLeft
                        .VerticalAlignment = xlTop
                        .WrapText = True
                        .MergeCells = True
                        .Value = txt
                    End With
                    sat = sat + say
                End If

                Cells(I, 2).Copy sf.Cells(sat, 1)
                txt = ""
                say = 0
            Else
                txt = Trim(txt) & " " & Cells(I, 2).Text
                If Cells(I, 2).MergeCells Then I = I + Cells(I, 2).MergeArea.Rows.Count - 1
            End If
        Else
            If Cells(I, 2).MergeCells Then I = I + Cells(I, 2).MergeArea.Rows.Count - 1
        End If
    Next I

End Sub

 

[spacebar]

üstad mükemmel olmuş ellerinize emeğinize sağlık. çok teşekkür ederim. sağlıklı günler dilerim.