H Kolonunda ondalık artırmak

[k0081]

Merhaba arkadaşlar;

H1 hücresine 1 yazdığımda; H5 den H53 e kadar olan hücrelerde 1 basamak artırmayı nasıl yapabilirim..?

örnek :
mevcut durum : H5= 6


istenen durum
H1 = 1
H5 = 6,0
...
...
***********
H1 = 2
H5 = 6,00

********** gibi..

yardımcı arkadaşa şimdiden teşekkürler..

 

[Ömer]

Merhaba,

2 seçenekten birini kullanabilirsiniz.

Buton ile; ( Module )

Sub Basamak()
 
    Dim say As String, yaz As String
 
    say = WorksheetFunction.Rept("0", [H1])
    If [H1] > 0 Then yaz = "." & say Else: yaz = ""
 
    Range("H5:H53").NumberFormat = "#,##0" & yaz
 
End Sub

H1 tetiklemesi ile; ( Sayfanın kod bölümüne )

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim say As String, yaz As String
 
    If Intersect(Target, [H1]) Is Nothing Then Exit Sub
 
    say = WorksheetFunction.Rept("0", Target)
    If Target > 0 Then yaz = "." & say Else: yaz = ""
 
    Range("H5:H53").NumberFormat = "#,##0" & yaz
 
End Sub

.

 

[k0081]

Merhaba,

hocam çok teşekkür ederim tamamdır..

********************

hocam buton kısmında çalışıyor .. fakat worksheet_change kısmına entegre edemedim.. mevcutta orada başka kodlar da var..

Private Sub Worksheet_Change(ByVal Target As Range)

 If Intersect(Target, Range("D3:D5")) Is Nothing Then Exit Sub
 With Application
        If Target <> "" Then
            .EnableEvents = False
            Target = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
            If Target.Address = "$D$4" Then Target = _
                                Replace(Target, "*", "x")
            .EnableEvents = True
   
        End If
   
End With
If InStr(1, [D5], "*", vbTextCompare) > 0 Then carp 'D5 hücresinde * yıldız işareti varsa "carp" makrosunu çalıştır.
If InStr(1, [D5], "/", vbTextCompare) > 0 Then bol 'D5 hücresinde / yıldız işareti varsa "bol" makrosunu çalıştır.

bir de söylemeyi unutmuşum H5 de sayılarım 6 m gibi H5 ile H53 arasında bu şekilde m ön eki bulunmaktadır...

 

[Ömer]

Sorunuzu destekleyen küçük bir örnek eklermisiniz. Konuyu anlarsam kodları sadeleştirme imkanım da olacaktır.

 

[k0081]

Sorunuzu destekleyen küçük bir örnek eklermisiniz. Konuyu anlarsam kodları sadeleştirme imkanım da olacaktır.

Dosyayı ekledim hocam..

Ekli dosyayı görüntüle ornek.xls

 

[Ömer]

Çarp böl makrosundan bahsettiniz fakat dosyada bu şekilde bi çalışma göremedim. Dosyayı eksiksiz ekleyip ayrıca konuyu dosya içinde açıklarsanız sevinirim.

 

[k0081]

Ömer;

Hocam çarp ve böl kısmında bir sıkıntı yok.. Dosya yeterli bence.. workssheet_change ile artırım yaptırmak istiyorum.. vermiş olduğunuz kodu workssheet in en üst satırına yazdığımda çalışıyor.. Fakat alt kısımda bulunan Büyük harfe çevirme vs.. kısmı çalışmıyor.. benim yapmak istediğim sizin vermiş olduğunuz artırım kodunu Worksheet_change içine entegre etmektir.. çalıştırmaktır. diğer kodu bozmadan...

 

[Ömer]

Siz bilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim say As String, yaz As String
 
    If Intersect(Target, Range("D3:D5,H1")) Is Nothing Then Exit Sub
 
    If Target.Column = 4 Then
        With Application
            If Target <> "" Then
                .EnableEvents = False
                Target = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
                If Target.Address = "$D$4" Then Target = _
                                Replace(Target, "*", "x")
                .EnableEvents = True
            End If
        End With
    End If
 
    If Target.Column = 8 Then
        say = WorksheetFunction.Rept("0", [H1])
        If [H1] > 0 Then yaz = "." & say Else: yaz = ""
        Range("H5:H53").NumberFormat = "#,##0" & yaz & """ m"""
    End If
 
'If InStr(1, [D5], "*", vbTextCompare) > 0 Then carp 'D5 hücresinde * yıldız işareti varsa "carp" makrosunu çalıştır.
'If InStr(1, [D5], "/", vbTextCompare) > 0 Then bol 'D5 hücresinde / yıldız işareti varsa "bol" makrosunu çalıştır.
End Sub

.

 

[k0081]

Ömer;

Hocam çok teşekkürler.. tamamdır.. elinize , Yüreğinize sağlık.. Saygılar..

 

[Ömer]

Önemli değil.

Eski konunuza bakarak çarp ve bölü neden kullandığınızı görebildim. İstemediniz fakat belki fikriniz değişir.
Çarp yada böl makrosuna gerek kalmadan aynı işlevi bu şekilde yapabilirsiniz. ( Mavi işaretli bölüm.)

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim say As String, yaz As String
 
    If Intersect(Target, Range("D3:D5,H1")) Is Nothing Then Exit Sub
 
    If Target.Column = 4 Then
        With Application
            If Target <> "" Then
                .EnableEvents = False
                Target = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
                If Target.Address = "$D$4" Then Target = _
                                     Replace(Target, "*", "x")
[COLOR=blue]                Range("D5").NumberFormat = "@"
                Range("D5") = Evaluate("=" & Range("D5"))
[/COLOR]                .EnableEvents = True
             End If
        End With
    End If
    
    If Target.Column = 8 Then
        say = WorksheetFunction.Rept("0", Target)
        If Target > 0 Then yaz = "." & say Else: yaz = ""
        Range("H5:H53").NumberFormat = "#,##0" & yaz & """ m"""
    End If
    
End Sub

.

 

[k0081]

Ömer;

Hocam çok teşekkürler.. önceki carp makrosunda 2 rakamı çarpabiliyordum.. sizin göndermiş olduğunuz bu kod ile 2 den fazlada rakam girebiliyorum..güzel oldu..

çok gerekli değil ama sadece merak ettiğim için soruyorum toplama işlemi de buraya eklenebilir mi ?

 

[Ömer]

Toplama,çarpma,bölme,çıkarma vs.. gibi, tüm işlemleri tek başına yada aynı anda yapar.

 

[k0081]

Toplama,çarpma,bölme,çıkarma vs.. gibi, tüm işlemleri tek başına yada aynı anda yapar.

çok teşekkürler hocam .. tamamdır.. geliştirilmiş oldu.., güzel oldu.. eyvallah sağolasın..