Metni, yazı tipi çeşitlemesine göre parçalarına ayırmak ?!?

[ManusH]

Selamlar,

ekteki örnek dosyada görülen gibi elimde uzun bir liste var.

Kalın, italik ve normal yazı tipi sıralaması ile başka herhangi bi ayraç da kullanılmadan yanyana dizilmiş verileri,
tekrar ayırarak ilgili sütunlara yazdırabilmeyi

sağlayacak makro konusunda yardımcı olabilir misiniz?

Şimdiden teşekkürler ...



ManusH

 

[Necdet]

Merhaba,

İlk aklıma gelen çözümü önerdim, başka yöntemler her zaman için vardır.

Sub Ayır()
[B2:D65000].ClearContents
For i = 2 To [A65536].End(3).Row
    dg = Trim(Cells(i, "A"))
    j = InStrRev(dg, " ")
    Cells(i, "D") = Right(dg, Len(dg) - j)
    Cells(i, "C") = Mid(dg, j - 2, 2)
    Cells(i, "B") = Left(dg, j - 3)
Next i
End Sub

 

[ManusH]

Selamlar,

Öncelikle ilginiz için teşekkür ederim.
Hazırladığınız kodu örnek liste üzerinde çalıştırınca tam aradığım sonuç diyecektim ama daha sonra içeriği incelediğimde farkettim ki siz çözüme benim aradığım yol haricinde bir yoldan ulaşmaya çalışmışsınız.

Benim listemde, sizin seçim yapmaya çalıştığınız gibi "boşlukların" herhangi bir önemi yok. önemli olan YAZI TİPİ ÇEŞİTLEMESİ.

Yani
1. bölüm KALIN
2. bölüm İTALİK
3. bölüm NORMAL
şeklinde yanyana dizilmişler.

Ayrım için tek kriterimiz bu.
(boşluk) gibi herhangi bir başka ayraç / belirleyici karakter
veya (2) şeklinde sabit bir karakter genişliği de söz konusu değil.


Bu konuda yardımcı olabilir, yol gösterebilirseniz memnun olurum.


Şimdiden teşekkürler...



ManusH

 

[Ferhat Pazarçevirdi]

Merhabalar

Necdet hocamın müsadesiyle,

Aşağıdaki kodu standart bir modül sayfasına kopyalayıp çalıştırınız.

Sub Parcalara_Ayir()
Dim i%, j%
Range("B2:D100").ClearContents
For i = 2 To Cells(65536, 1).End(xlUp).Row
    For j = 1 To Len(Cells(i, 1).Text)
        If Cells(i, 1).Characters(Start:=j, Length:=1).Font.FontStyle = "Kalın" Then
           Cells(i, 2) = Cells(i, 2) & Mid(Cells(i, 1), j, 1)
        Else
           If Cells(i, 1).Characters(Start:=j, Length:=1).Font.FontStyle = "İtalik" Then
              Cells(i, 3) = Cells(i, 3) & Mid(Cells(i, 1), j, 1)
           Else
              Cells(i, 4) = Cells(i, 4) & Mid(Cells(i, 1), j, 1)
           End If
        End If
    Next j
Next i
End Sub

 

[Necdet]

Merhaba,

Sayın fpc yanıtlamış, bende uğraşmıştım boşa gitmesin

Sub Aktar()
For i = 2 To [a65536].End(3).Row
    Koyu = ""
    Italik = ""
    Normal = ""
    For j = 1 To Len(Cells(i, "A"))
        With Range("A" & i).Characters(j, 1).Font
            If .Bold Then Koyu = Koyu & Mid(Cells(i, "A"), j, 1)
            If .Italic Then Italik = Italik & Mid(Cells(i, "A"), j, 1)
            If .Bold = False And .Italic = False Then Normal = Normal & Mid(Cells(i, "A"), j, 1)
        End With
    Next j
    Cells(i, "B") = Koyu
    Cells(i, "C") = Italik
    Cells(i, "D") = Normal
Next i
End Sub

 

[ManusH]

Selamlar,

İlginize teşekkürler.

Yapmaya çalıştığım da tam olarak buydu, örnek listede sorunsuz bi şekilde "kalın, italik ve normal" ayrımını gerçekleştiriyor.

Artık listelerimi düzenlemeye geçebilirim sanırım

tekrar teşekkürler...




Saygılarımla,

ManusH