Metin ile simge birleştirme

[Believing]

Sayın Uzman Arkadaşlar,

Ekteki dosyada yapılan çalışmada, hücre içerisinde metnin sonuna istenilen ölçüte göre yıldız simgesi konulmak isteniyor. Ekteki örnek çalışmada detaylı anlatım mevcut olup, siz uzman arkadaşların çok değerli yardımını rica ediyorum.

Saygılarımla.

 

[Ömer]

Merhaba,

Bu işlemi formül ile değil makro ile çözebilirsiniz.

Yalnız parametre sayfasında C ile D birleşecek sanırım. H ve I sütunu açıklamalarda kullanmışsınız. Bir faktörü var mı. Varsa daha detaylı açıklayınız.

 

[Believing]

Sayın Ömer Bey,

Öncelikle konuya gösterdiğiniz ilgi için size teşekkür ederim. H ve I sütunları sadece açıklama için girmiştir. C ile D birleşecek, birleşirken D sütunu ölcüt olarak kullanılarak, yıldızlar simge olarak eklenmek isteniyor. Makro ile yapılmasında herhangi bir sakınca olmamakla birlikte, konusunda oldukca eksiğim ve konuyu çözebilecek yeterliliğe sahip değilim.

Saygılarımla.

 

[Ömer]

Tabloyu anlamaya çalışıyorum.
Tablo da ekteki gibi 10 satırda bir kod no girişi mi var. Yani düzen bu şekilde mi olacak.
Kodların çalışması, K sütunu yani kod noları girince mi çalışsın yoksa buton ile mi?

 

[Believing]

Sayın Ömer Bey,

Evet doğru tespitte bulunmuşsunuz her 10 satırda bir K sütununda kod girişi bulunmaktadır. K sütununa kod girilince çalışan bir kuguya ihtiyacım var. Her hangi bir buton çalışmasına ihtiyaç yoktur.

Saygılarımla.

 

[Ömer]

İlgili sayfanın kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Sp As Worksheet, d As Range, a As String, b As String, c As String
 
    If Intersect(Target, Range("K:K")) Is Nothing Then Exit Sub
 
    Set Sp = Sheets("Parametre")
 
    Application.ScreenUpdating = False
    With Target
        If (.Row - 4) Mod 9 <> 0 Then Exit Sub
        Set d = Sp.Range("B:B").Find(.Value, , xlValues, xlWhole)
        If Not d Is Nothing Then
            c = ""
            If Val(Sp.Cells(d.Row, "D")) <> Sp.Cells(d.Row, "D") Then
                c = "¶"
            End If
            b = Application.Rept("ê", Val(Sp.Cells(d.Row, "D")))
            a = Sp.Cells(d.Row, "C")
            .Offset(0, 1) = a & b & c
        End If
       .Offset(0, 1).Font.Name = "Arial Tur"
       .Offset(0, 1).Characters(Len(a) + 1, Len(b)).Font.Name = "Wingdings 2"
        If c <> "" Then
          .Offset(0, 1).Characters(Len(a & b) + 1, 1).Font.Name = "Wingdings"
        End If
    End With
    Application.ScreenUpdating = True
 
End Sub

.

 

[Believing]

Sayın Ömer Bey,

Kodlar son derece güzel çalışıyor. Peki sayfayı korumaya alırsam kodlarda nasıl değişikliğe gitmeliyim. Son kez bir yardım daha rica ediyorum.

Saygılarımla.

 

[Believing]

Sayın Ömer bey,

Çok değerli yardımlarınız için size çok teşekkür ederim. Korumalı sayfada sizin verdiğiniz kodu aşağıdaki gibi düzenleyerek çalıştırdım. Konuyu takip edenler için aşağıdaki gibi paylaşıyorum.

Saygılarımla.

Private Sub Worksheet_Change(ByVal Target As Range)
 ActiveSheet.Unprotect "[COLOR="Red"]Şifrenizi buyraya yazınız[/COLOR]"
    Dim Sp As Worksheet, d As Range, a As String, b As String, c As String
 
    If Intersect(Target, Range("K:K")) Is Nothing Then Exit Sub
 
    Set Sp = Sheets("Parametre")
 
    Application.ScreenUpdating = False
    With Target
        If (.Row - 4) Mod 9 <> 0 Then Exit Sub
        Set d = Sp.Range("B:B").Find(.Value, , xlValues, xlWhole)
        If Not d Is Nothing Then
            c = ""
            If Val(Sp.Cells(d.Row, "D")) <> Sp.Cells(d.Row, "D") Then
                c = ""
            End If
            b = Application.Rept("ê", Val(Sp.Cells(d.Row, "D")))
            a = Sp.Cells(d.Row, "C")
            .Offset(0, 1) = a & b & c
        End If
       .Offset(0, 1).Font.Name = "Arial Tur"
       .Offset(0, 1).Characters(Len(a) + 1, Len(b)).Font.Name = "Wingdings 2"
        If c <> "" Then
          .Offset(0, 1).Characters(Len(a & b) + 1, 1).Font.Name = "Wingdings"
        End If
    End With
    Application.ScreenUpdating = True
    ActiveSheet.Protect "[COLOR="Red"]Şifrenizi buyraya yazınız[/COLOR]"
    End Sub

 

[Ömer]

Rica ederim. Yalnız buçuklar için kullandığınız "¶" simgesi bölümünü değiştirmişsiniz.

Yazdığım; c = "¶" iken,
siz; c = "" olarak değiştirmişsiniz.

.

 

[Believing]

Sayın Ömer Bey,

Tekrar teşekkür ederim dikkatiniz için, Zira c = "¶" karekterlerini eklemiyormuş, şimdi eklemeye başladı.

Saygılarımla.