Macro ile hücre biçimlendirme

[figutive]

Merhabalar

Küçük bir hatırlatma yaparak sizden yardımcı olmanızı isteyecektim; macroyu hemen hemen hiç bilmiyorum, sizler için basit sayılabilecek düzeltmeleri dahi yapamayacak durumdayım. Bu nedenle yazılan macro basitte olsa hata içeriyorsa çalıştıramayacağım.

Kullandığımız programdan excele otomatik rapor çıktısı alıyoruz. Ancak alınan veri hücrede özellikleri sıfırlayıp getiriyor. Paragraf aralarını siliyor, bold karekterleri normale çeviriyor vb.

Örnek verecek olursam default gelen veri aşağıdaki gibi

Kriter: Basel Komite'nin sermaye yeterliliğine ilişkin yeni düzenlemesi (Basel-II) hakkında bankacılık sisteminin bilgilendirilmesi, söz konusu düzenlemeler konusunda bankacılık sisteminin görüşlerinin dile getirilmesi. Tespit: ankacılık sektörünün Basel II düzenlemesine hazırlanması amacıyla Komite tarafından oluşturulan ve Bankacılık Düzenleme ve Denetleme Kurumu tarafından kamuoyuna açıklanan Basel II Yol Haritasındaki süreçlere ilişkin olarak Yönlendirme Komitesi koordinasyonunda çalışmak üzere çeşitli konularda görev alan alt çalışma grupları oluşturulmuştur. Sebep: Sistem kullanıcılarının sehven hataya sebebiyet vermesi, tespit için tanımlı kontrollerin olmaması/kullanılmaması mevcut duruma sebebiyet verebilmektedir. Etki ve riskler: Müşteri memnuniyetsizliğine ve hukuki anlaşmazlıklara sebep olabilmektedir.


Hücrede olması gereken ise böyle

Kriter: Basel Komite'nin sermaye yeterliliğine ilişkin yeni düzenlemesi (Basel-II) hakkında bankacılık sisteminin bilgilendirilmesi, söz konusu düzenlemeler konusunda bankacılık sisteminin görüşlerinin dile getirilmesi.

Tespit: ankacılık sektörünün Basel II düzenlemesine hazırlanması amacıyla Komite tarafından oluşturulan ve Bankacılık Düzenleme ve Denetleme Kurumu tarafından kamuoyuna açıklanan Basel II Yol Haritasındaki süreçlere ilişkin olarak Yönlendirme Komitesi koordinasyonunda çalışmak üzere çeşitli konularda görev alan alt çalışma grupları oluşturulmuştur.

Sebep: Sistem kullanıcılarının sehven hataya sebebiyet vermesi, tespit için tanımlı kontrollerin olmaması/kullanılmaması mevcut duruma sebebiyet verebilmektedir.

Etki ve riskler: Müşteri memnuniyetsizliğine ve hukuki anlaşmazlıklara sebep olabilmektedir.

Başlıklarımız hep aynı, Kriter: , Tespit: , Sebep: , Etki ve riskler:

yaptığım işlemi anlatacak olursam
Kriter: bu başlığı sadece bold yapıyorum.
Tespit: bu başlığı bold yapıp önceki paragrafla arasını açıyorum
Sebep: bu başlığı bold yapıp önceki paragrafla arasını açıyorum
Etki ve riskler: bu başlığı bold yapıp önceki paragrafla arasını açıyorum

acil yardımcı olabilirseniz çok sevinirim

Selamlar

 

[Korhan Ayhan]

Merhaba,

Verilerinizin yedeğini alıp aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub VERİLERİ_DÜZENLE()
    Dim Hücre As Range, Cümle As Variant
    Dim X As Integer, Bul As Byte, İlk As Integer
    
    Application.ScreenUpdating = False
    
    For Each Hücre In Selection
        Hücre.Value = WorksheetFunction.Clean(Hücre.Text)
        Hücre.Replace ". ", "."
        Hücre.Replace ".", "." & Chr(10) & Chr(10)
        Cümle = Split(Hücre.Text, "." & Chr(10) & Chr(10))
        For X = 0 To UBound(Cümle) - 1
            Bul = InStr(Cümle(X), ":")
            If Bul > 0 Then
                If İlk = 0 Then İlk = 1
                Hücre.Characters(İlk, Bul + 1).Font.Bold = True
                İlk = İlk + Len(Cümle(X)) + X + 2
            End If
        Next
        İlk = 0
    Next
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[figutive]

Merhabalar

Cevap için çok teşekkürler bir arkadaş yardımcı oldu. aşağıdaki macro benim sorunumu çözdü. bil olarak kalması açısından aşağı kopyalıyorum

Selamlar




Dim imge As Long, _
j As Integer, _
Bs As Integer, _
Uz As Integer, _
s, _
Mtn As String

Application.ScreenUpdating = False

Columns("A:A").Replace What:="Etki ve Riskler", Replacement:="Etki*ve*Riskler", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False

For imge = 2 To Cells(Rows.Count, "A").End(xlUp).Row

s = Split(Cells(imge, "A"), " ")
Mtn = ""

For j = 0 To UBound(s)
If s(j) Like "*:" And j > 0 Then Mtn = Mtn & Chr(10) & Chr(10)
Mtn = Mtn & " " & s(j)
Next j

Cells(imge, "A") = Mtn
s = Split(Cells(imge, "A"), " ")
For j = 0 To UBound(s)
If s(j) Like "*:" Then
Uz = Len(s(j))
Bs = InStr(1, Cells(imge, "A"), s(j), vbTextCompare)
Range("A" & imge).Characters(Bs, Uz).Font.Bold = True
End If
Next j
Next imge

Application.ScreenUpdating = True

MsgBox "İşlem Tamamdır.....", vbInformation, "N. YEŞERTENER -- www.excel.web.tr"