Çözüldü Hücre Biçimine göre kopyalamak

[hasankardas]

Merhabalar,
Hücre biçimi (Kalın) olan hücrenin altındaki hücreleri yanına kopyalamak istiyorum..
Yardımlarınız için teşekkür ederim.

İndir HÜCRE BİÇİMİNE

Dosyayı indir HÜCRE BİÇİMİNE

dosya.co

 

[hamitcan]

Böyle dener misiniz ?

Sub test()
    Dim kalin()
    
     Columns("i:j").ClearContents

    x = Range("a1").End(xlDown).Row
    For Each hcr In Range("a1:a" & x)
        If hcr.Font.Bold = True Then
            k = k + 1
            ReDim Preserve kalin(1 To k)
            kalin(k) = hcr.Text
        End If
    Next
    t = 2
    For i = 1 To UBound(kalin)
    t = t + 1
        Cells(t, "i") = kalin(i)
        Cells(t, "i").Font.Bold = True
    Next
    t = 3
    For i = 2 To x + 1
        If Cells(i, 1).Font.Bold = True Or Cells(i, 1) = "" Then
        Cells(t, "j") = Mid(Cells(t, "j"), 2, Len(Cells(t, "j")))
        i = i + 1: t = t + 1
        End If
        Cells(t, "j") = Cells(t, "j") & "," & Cells(i, 1)
    Next
End Sub

 

[hasankardas]

Teşekkür ederim çalışıyor