• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Ondalık Artır, Ondalık Eksilt Kodu Nedir

  • Konbuyu başlatan Konbuyu başlatan kykbt
  • Başlangıç tarihi Başlangıç tarihi
K

kykbt

Katılım
12 Nisan 2006
Mesajlar
303
Excel Vers. ve Dili
Office 2003
Office 2007
Arkadaşlar Merhaba

Makro ile menüdeki ondalık artır veya ondalık eksilt butonunun yaptığı iş yapmak istiyorum.

Yani butona bastığımda ondalık artacak veya eksilecek.
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub ONDALIK_ARTTIR()
    Dim HÜCRE As Range, AYIR() As String
    
    For Each HÜCRE In Selection
    If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
    AYIR = Split(HÜCRE.NumberFormat, ".")
    If Len(AYIR(1)) < 30 Then
    HÜCRE.NumberFormat = AYIR(0) & "." & AYIR(1) & 0
    End If
    Else
    HÜCRE.NumberFormat = "0.0"
    End If
    Next
End Sub
 
Sub ONDALIK_AZALT()
    Dim HÜCRE As Range, AYIR() As String
    
    For Each HÜCRE In Selection
    If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
    AYIR = Split(HÜCRE.NumberFormat, ".")
    HÜCRE.NumberFormat = AYIR(0) & "." & Left(AYIR(1), Len(AYIR(1)) - 1)
    If HÜCRE.NumberFormat = "0." Then HÜCRE.NumberFormat = "General"
    Else
    HÜCRE.NumberFormat = "General"
    End If
    Next
End Sub
 
Hocam Merhaba

Verdiğiniz kodu aşağıdaki şekilde kullanmam gerekiyordu.

Ancak bu şekilde yaptığım formatlamada, ondalık artırma ve eksiltmede sıfırları sona ekliyor.

Benim için gerekli olan ise yaptığım format şeklinde artırıp eksiltme yapabilmeli.

Yardımlarınız için çok teşekkür ediyorum.

Kod: 
Sub auto_open()
    Application.OnKey "{F1}", "TL"
    Application.OnKey "{F2}", "DOLAR"
    Application.OnKey "{F3}", "EURO"
End Sub


Sub TL()
Selection.NumberFormat = "#,##0.00 [$TL]"
End Sub
Sub DOLAR()
Selection.NumberFormat = "#,##0.00 [$$]"
End Sub
Sub EURO()
    Selection.NumberFormat = "#,##0.00 [$€]"
End Sub

Sub auto_close()
'On Error Resume Next
    Application.OnKey "{F1}"
    Application.OnKey "{F2}"
    Application.OnKey "{F3}"
End Sub
 
Hocalarım yapmak istediğim makro bütünü böyle, fakat ondalık kısmı sıkıntılı, yardıma ihtiyac var.
Kod: 
Option Explicit
Sub auto_open()
    Application.OnKey "{F1}", "TL"
    Application.OnKey "{F2}", "DOLAR"
    Application.OnKey "{F3}", "EURO"
    Application.OnKey "{F4}", "ONDALIK_ARTTIR"
    Application.OnKey "{F5}", "ONDALIK_AZALT"
End Sub


Sub TL()
Selection.NumberFormat = "#,##0.00 [$TL]"
End Sub
Sub DOLAR()
Selection.NumberFormat = "#,##0.00 [$$]"
End Sub
Sub EURO()
    Selection.NumberFormat = "#,##0.00 [$€]"
End Sub
 
Sub ONDALIK_ARTTIR()
    Dim HÜCRE As Range, AYIR() As String
    
    For Each HÜCRE In Selection
    If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
    AYIR = Split(HÜCRE.NumberFormat, ".")
    If Len(AYIR(1)) < 30 Then
    HÜCRE.NumberFormat = AYIR(0) & "." & AYIR(1) & 0
    End If
    Else
    HÜCRE.NumberFormat = "0.0"
    End If
    Next
End Sub
 
Sub ONDALIK_AZALT()
    Dim HÜCRE As Range, AYIR() As String
    
    For Each HÜCRE In Selection
    If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
    AYIR = Split(HÜCRE.NumberFormat, ".")
    HÜCRE.NumberFormat = AYIR(0) & "." & Left(AYIR(1), Len(AYIR(1)) - 1)
    If HÜCRE.NumberFormat = "0." Then HÜCRE.NumberFormat = "General"
    Else
    HÜCRE.NumberFormat = "General"
    End If
    Next
End Sub

Sub auto_close()
'On Error Resume Next
    Application.OnKey "{F1}"
    Application.OnKey "{F2}"
    Application.OnKey "{F3}"
    Application.OnKey "{F4}"
    Application.OnKey "{F5}"
End Sub
 
Hocalarım Merhaba

Bir el atsak.? Takıldım kaldım.
 
Arkadaşlar Tekrar Merhaba

Bu konuyu hala çözemedim yardım edecek birileri illaki olabilir dedim.
Yabancı siteleride gezdim henüz çözemedim.
Bunu excel kendi yapıyor ise bizde çözebiliriz dedim ama!!!!!!
 
Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Kod: 
Option Explicit
 
Sub AUTO_OPEN()
    Application.OnKey "{F1}", "TL"
    Application.OnKey "{F2}", "DOLAR"
    Application.OnKey "{F3}", "EURO"
    Application.OnKey "{F4}", "KG"
    Application.OnKey "{F5}", "ONDALIK_ARTTIR"
    Application.OnKey "{F6}", "ONDALIK_AZALT"
End Sub
 
Sub TL()
    Selection.NumberFormat = "#,##0.00 [$TL]"
End Sub
 
Sub DOLAR()
    Selection.NumberFormat = "#,##0.00 [$$]"
End Sub
 
Sub EURO()
    Selection.NumberFormat = "#,##0.00 [$€]"
End Sub
 
Sub KG()
    Dim HÜCRE As Range
 
    For Each HÜCRE In Selection
        If InStr(1, HÜCRE.NumberFormat, "Kg") = 0 Then
            HÜCRE.NumberFormat = HÜCRE.NumberFormat & """ / Kg"""
        End If
    Next
End Sub
 
Sub ONDALIK_ARTTIR()
    Dim HÜCRE As Range, AYIR() As String
 
    For Each HÜCRE In Selection
        If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
            AYIR = Split(HÜCRE.NumberFormat, ".")
                If Len(AYIR(1)) < 30 Then
                    HÜCRE.NumberFormat = AYIR(0) & "." & "0" & AYIR(1)
                End If
        Else
            AYIR = Split(HÜCRE.NumberFormat, " ")
            If Len(HÜCRE.NumberFormat) - Len(Replace(HÜCRE.NumberFormat, " ", "")) > 1 Then
                HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1) & " " & AYIR(2) & " " & AYIR(3)
            Else
                HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1)
            End If
        End If
    Next
End Sub
 
Sub ONDALIK_AZALT()
    Dim HÜCRE As Range, AYIR() As String, PARA_BİRİMİ As String
 
    For Each HÜCRE In Selection
        If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
            AYIR = Split(HÜCRE.NumberFormat, ".")
            PARA_BİRİMİ = Replace(AYIR(1), 0, "")
            HÜCRE.NumberFormat = AYIR(0) & "." & Right(AYIR(1), Len(AYIR(1)) - 1)
            If InStr(1, HÜCRE.NumberFormat, ". ") > 0 Then HÜCRE.NumberFormat = "#,##0" & PARA_BİRİMİ
        End If
    Next
End Sub
 
Sub AUTO_CLOSE()
    Application.OnKey "{F1}", ""
    Application.OnKey "{F2}", ""
    Application.OnKey "{F3}", ""
    Application.OnKey "{F4}", ""
    Application.OnKey "{F5}", ""
    Application.OnKey "{F6}", ""
End Sub
 

Ekli dosyalar

Hocam Merhaba

Harika olmuş bu kadar uğraşmış idim ki,

Çok teşekkür ediyorum. Ve zahmat olmaz ise aşağıda koda bir ilave yaptım
F6 tuşu para formatından sonra bu tuş ilede ilave bir format daha atıyorum.

Burada sıkıntı ONDALIK_ARTTIR da Else durumunda F6 formatını iptal etmesidir.

Hocam bir ilgi daha gösterirseniz. Ne diyeyim.!!!!!

Korhan Ayhan' Alıntı:
Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Kod: 
Option Explicit
 
Sub AUTO_OPEN()
    Application.OnKey "{F1}", "TL"
    Application.OnKey "{F2}", "DOLAR"
    Application.OnKey "{F3}", "EURO"
    Application.OnKey "{F4}", "ONDALIK_ARTTIR"
    Application.OnKey "{F5}", "ONDALIK_AZALT"
Application.OnKey "{F6}", "Ekle_Kg"
End Sub
 
Sub TL()
    Selection.NumberFormat = "#,##0.00 [$TL]"
End Sub
 
Sub DOLAR()
    Selection.NumberFormat = "#,##0.00 [$$]"
End Sub
 
Sub EURO()
    Selection.NumberFormat = "#,##0.00 [$€]"
End Sub
Sub Ekle_Kg()
    Selection.NumberFormat = " " & Selection.NumberFormat & " ""/ Kg"""
End Sub
 
Sub ONDALIK_ARTTIR()
    Dim HÜCRE As Range, AYIR() As String
    
    For Each HÜCRE In Selection
        If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
            AYIR = Split(HÜCRE.NumberFormat, ".")
                If Len(AYIR(1)) < 30 Then
                    HÜCRE.NumberFormat = AYIR(0) & "." & "0" & AYIR(1)
                End If
        Else
            AYIR = Split(HÜCRE.NumberFormat, " ")
            HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1)
        End If
    Next
End Sub
 
Sub ONDALIK_AZALT()
    Dim HÜCRE As Range, AYIR() As String, PARA_BİRİMİ As String
    
    For Each HÜCRE In Selection
        If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
            AYIR = Split(HÜCRE.NumberFormat, ".")
            PARA_BİRİMİ = Replace(AYIR(1), 0, "")
            HÜCRE.NumberFormat = AYIR(0) & "." & Right(AYIR(1), Len(AYIR(1)) - 1)
            If InStr(1, HÜCRE.NumberFormat, ". ") > 0 Then HÜCRE.NumberFormat = "#,##0" & PARA_BİRİMİ
        End If
    Next
End Sub
 
Sub AUTO_CLOSE()
    Application.OnKey "{F1}", ""
    Application.OnKey "{F2}", ""
    Application.OnKey "{F3}", ""
    Application.OnKey "{F4}", ""
    Application.OnKey "{F5}", ""
Application.OnKey "{F6}", ""
End Sub
Genişletmek için tıkla ...
 
Selamlar,

Üstteki mesajımdaki dosyayı ve kodu güncelledim. İncelermisiniz.
 
Hocam Tekrar Merhaba

Eğer ilk format TL / Kg gibi ek formatlı ise sonra Ondalık azalt ile sadece sayı örneğin "45 TL / Kg " gibi bir değere geldiğinizde tekrar ONDALIK_ARTTIR da aşağıdaki kodda hata veriyor artıramıyorsunuz.

If Len(HÜCRE.NumberFormat) - Len(Replace(HÜCRE.NumberFormat, " ", "")) > 1 Then
HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1) & " " & AYIR(2) & " " & AYIR(3)
Genişletmek için tıkla ...


Eğer ilk format "Genel" veya Sayı ise "0" ise ONDALIK_ARTTIR da aşağıdaki kodda hata veriyor

Else
HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1)
End If
Genişletmek için tıkla ...

Sadece Para formatında ise problem yok.
 
Selamlar,

En son eklemiş olduğum dosyada "TL / Kg" formatında ben bir sorun göremedim. İki makroda sağlıklı çalışıyor. Sizin yazdığınız formatta "Kg" ibaresinden sonra bir boşluk var sanırım sorun bundan kaynaklanabilir.

Kodun "Genel" ve "Sayı" formatında da düzgün çalışması için boş bir vaktimde gerekli eklemeleri hazırlayıp önceki mesajıma eklerim.
 
Hocam Merhaba

Kodu biraz uğraşarak aşağıdaki hale getirdim ve problemsiz çalışıyor.
İhtiyacı olan olabilir diye ekleyeyim dedim.
(Belki yinede kodda düzeltme veya kısaltma yapılabilir)

Sub ONDALIK_ARTTIR()
Dim HÜCRE As Range, AYIR() As String
On Error Resume Next
'
For Each HÜCRE In Selection
If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
AYIR = Split(HÜCRE.NumberFormat, ".") 'Noktadan AYIR
PARA_BİRİMİ = Replace(AYIR(1), 0, "")
If Len(AYIR(1)) < 30 Then
HÜCRE.NumberFormat = AYIR(0) & "." & "0" & AYIR(1)
End If
Else
AYIR = Split(HÜCRE.NumberFormat, " ") 'Her boşlukta AYIR
PARA_BİRİMİ = Replace(AYIR(1), 0, "")
If Len(HÜCRE.NumberFormat) - Len(Replace(HÜCRE.NumberFormat, " ", "")) > 1 Then
HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & AYIR(1) & " " & AYIR(2) & " " & AYIR(3)
Else 'Sadece Para Formatı Ondalık Yok İse, İlk Ondalık İçin
If HÜCRE.NumberFormat = "General" And ActiveCell > 0 Then HÜCRE.NumberFormat = "0.0"
If HÜCRE.NumberFormat = "0" And ActiveCell > 0 Then HÜCRE.NumberFormat = AYIR(0) & "." & "0": Exit Sub
HÜCRE.NumberFormat = AYIR(0) & "." & "0 " & PARA_BİRİMİ
End If
End If
Next
End Sub
Genişletmek için tıkla ...

Sub ONDALIK_AZALT()
Dim HÜCRE As Range, AYIR() As String, PARA_BİRİMİ As String
On Error Resume Next
'
For Each HÜCRE In Selection
If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then
AYIR = Split(HÜCRE.NumberFormat, ".")
PARA_BİRİMİ = Replace(AYIR(1), 0, "")
HÜCRE.NumberFormat = AYIR(0) & "." & Right(AYIR(1), Len(AYIR(1)) - 1)

If HÜCRE.NumberFormat = "0." & PARA_BİRİMİ And ActiveCell > 0 Then _
HÜCRE.NumberFormat = AYIR(0) & PARA_BİRİMİ: Exit Sub
If InStr(1, HÜCRE.NumberFormat, ". ") > 0 Then HÜCRE.NumberFormat = "#,##0" & PARA_BİRİMİ
Else
If InStr(1, HÜCRE.NumberFormat, ".") > 0 Then HÜCRE.NumberFormat = AYIR(0) ' & AYIR(1)
End If
Next
End Sub
Genişletmek için tıkla ...

yardımlarınıza teşekkür ediyorum.
 
Selamlar,

Çözüm yolunu bulduğunuz için tebrik ederim. Ben biraz daha genel bir kodlama düşünmüştüm. Ama hepsini kodla kontrol etmek gerçekten zor. Hele işin içine özel biçimlendirmeler girince çözüme ulaşmak daha da zorlaşıyor. Siz bu şekilde kullanmaya devam edin. Eğer daha basit bir uygulama bulursam eklerim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst