Çözüldü Hücre Değerini Şarta Bağlı Olarak Arttırmak

[iska1]

Merhaba;

Uzun zamandır çözmeye çalıştığım bir sorun hakkında yardımlarınıza ihtiyaç duydum. Konunun detayını izah etmek gerekirse; kendim oluşturmuş olduğum Teklif Formu ve Tahsilat Makbuzu çalışmalarımda işime yarayacak çoğu şeyi otomatik olarak yapabiliyorum ancak tüm uğraşlarıma rağmen bulmuş olduğum vba makrolar dahil tam olarak istediğim şeyi başaramadım. O da şu: Teklif Formunda ‘Teklif Numarası’, Tahsilat Makbuzunda ise ‘Sıra Numarası’ hücrelerin değerinin her işlemde müdahale etmeden otomatik olarak 1 sayı artması. Bunun için değişkenler müşteri adını seçtiğimde de olabilir farklı kaydet yaptıktan sonra da olabilir. Örnek olarak 00012 numaralı makbuzu kesip kapattığımda 00012 sıra no kalmalı, müşteriyi değiştirdiğimde ve tekrar yeni işlem yapıp farklı kaydet seçtiğimde 00013 olarak devam etmeli.

Yardımlarınızı esirgemeden, destekleriniz ve çözüm önerilerinizi vakit ayırarak paylaşmaya değer bulduğunuz için şimdiden çok teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Örnek dosya paylaşırsanız dosyanıza göre çözüm önerilerinde bulunabiliriz.

 

[iska1]

Merhaba,

Örnek dosya paylaşırsanız dosyanıza göre çözüm önerilerinde bulunabiliriz.

Merhaba,

Dosya bağlantısını aşağıda paylaşıyorum.

WeTransfer - Send Large Files & Share Photos Online - Up to 2GB Free

WeTransfer is the simplest way to send your files around the world

we.tl

 

[Mdemir63]

Selamlar

Makbuz Sayfasının kod penceresine aşağıdaki kodları yapıştırıp deneyiniz

 Private Sub Worksheet_Change(ByVal Target As Range)
      If Intersect(Target, [E8]) Is Nothing Then Exit Sub
      If Range("E8") <> "" Then
           Range("M6") = Range("M6") + 1
      End If
End Sub

 

[iska1]

Selamlar

Makbuz Sayfasının kod penceresine aşağıdaki kodları yapıştırıp deneyiniz

 Private Sub Worksheet_Change(ByVal Target As Range)
      If Intersect(Target, [E8]) Is Nothing Then Exit Sub
      If Range("E8") <> "" Then
           Range("M6") = Range("M6") + 1
      End If
End Sub

Desteğiniz için teşekkür ederim ancak kodu çalıştıramadım veya herhangi bir değişiklik olmadı. Hangi koşula bağlı olarak çalışması gerekiyor?
Benim isteğim mesela 'Dışa Aktar' yaptıktan sonra +1 olarak artması mümkün mü?

 

[Mdemir63]

Selamlar
Veri doğrulama yapmış olduğunuz hücrede değişiklik yaptığınızda sıra no yazan yeri gözlemleyiniz

 

[iska1]

Selamlar
Veri doğrulama yapmış olduğunuz hücrede değişiklik yaptığınızda sıra no yazan yeri gözlemleyiniz

Selamlar,
Vermiş olduğunuz kodun işlevi isteğime yönelik fakat sorun ayrı bir kod daha kullanıyor olmam sanırım. Sizin vermiş olduğunuz kod ile aşağıda paylaşmış olduğum kodu nasıl birleştirip ikisini de aynı anda çalıştırabilirim? VBA üzerine bir tecrübem olmadığı için bunu yapamıyorum. İlgi ve desteğiniz için teşekkürler.



Function ParaCevir(para As Double)
If Not IsNumeric(sayi) Then GoTo Hata
If (para - Int(para)) = 0 Then
ParaCevir = Cevir(para)
Else
tamsayi = Cevir(Int(para))
ondalik = Cevir((para - Int(para)) * 100)
ondalik = LCase(Mid(ondalik, 1, 1)) + Mid(ondalik, 2, Len(ondalik) - 1)
ParaCevir = tamsayi + "virgül" + ondalik
End If
GoTo tamam
Hata:
ParaCevir = "Hata"
tamam:
End Function

Private Function Cevir(sayi As Double)

Dim b(9) As String
Dim y(9) As String
Dim m(4) As String
Dim v(15)
Dim c(3)

b(0) = ""
b(1) = "bir"
b(2) = "iki"
b(3) = "üç"
b(4) = "dört"
b(5) = "beş"
b(6) = "altı"
b(7) = "yedi"
b(8) = "sekiz"
b(9) = "dokuz"

y(0) = ""
y(1) = "on"
y(2) = "yirmi"
y(3) = "otuz"
y(4) = "kırk"
y(5) = "elli"
y(6) = "altmış"
y(7) = "yetmiş"
y(8) = "seksen"
y(9) = "doksan"

m(0) = "trilyon"
m(1) = "milyar"
m(2) = "milyon"
m(3) = "bin"
m(4) = ""

a = Str(Round(sayi, 0))
If Left(a, 1) = " " Then pozitif = 1 Else pozitif = 0
a = Right(a, Len(a) - 1)

If Len(a) > 15 Then GoTo Hata
a = String(15 - Len(a), "0") + a

For x = 1 To 15
v(x) = Val(Mid(a, x, 1))
Next x

s = ""
For x = 0 To 4
c(1) = v(x * 3 + 1)
c(2) = v(x * 3 + 2)
c(3) = v(x * 3 + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "yüz"
Else
e = b(c(1)) + "yüz"
End If
e = e + y(c(2)) + b(c(3))
If e = "" Then e = e + m(x)
If (x = 3) And (e = "birbin") Then e = "bin"
s = s + e
Next x

If s = "" Then s = "sıfır"
If pozitif = 0 Then s = "eksi" + s

Cevir = UCase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1)
End Function
Exit Sub
Hata:
Cevir = "HATA"
End Function



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub


If Intersect(Target, [E8]) Is Nothing Then Exit Sub
If Range("E8") <> "" Then
Range("M6") = Range("M6") + 1
End If
End Sub

 

[Mdemir63]

Selamlar,
Vermiş olduğunuz kodun işlevi isteğime yönelik fakat sorun ayrı bir kod daha kullanıyor olmam sanırım. Sizin vermiş olduğunuz kod ile aşağıda paylaşmış olduğum kodu nasıl birleştirip ikisini de aynı anda çalıştırabilirim? VBA üzerine bir tecrübem olmadığı için bunu yapamıyorum. İlgi ve desteğiniz için teşekkürler.



Function ParaCevir(para As Double)
If Not IsNumeric(sayi) Then GoTo Hata
If (para - Int(para)) = 0 Then
ParaCevir = Cevir(para)
Else
tamsayi = Cevir(Int(para))
ondalik = Cevir((para - Int(para)) * 100)
ondalik = LCase(Mid(ondalik, 1, 1)) + Mid(ondalik, 2, Len(ondalik) - 1)
ParaCevir = tamsayi + "virgül" + ondalik
End If
GoTo tamam
Hata:
ParaCevir = "Hata"
tamam:
End Function

Private Function Cevir(sayi As Double)

Dim b(9) As String
Dim y(9) As String
Dim m(4) As String
Dim v(15)
Dim c(3)

b(0) = ""
b(1) = "bir"
b(2) = "iki"
b(3) = "üç"
b(4) = "dört"
b(5) = "beş"
b(6) = "altı"
b(7) = "yedi"
b(8) = "sekiz"
b(9) = "dokuz"

y(0) = ""
y(1) = "on"
y(2) = "yirmi"
y(3) = "otuz"
y(4) = "kırk"
y(5) = "elli"
y(6) = "altmış"
y(7) = "yetmiş"
y(8) = "seksen"
y(9) = "doksan"

m(0) = "trilyon"
m(1) = "milyar"
m(2) = "milyon"
m(3) = "bin"
m(4) = ""

a = Str(Round(sayi, 0))
If Left(a, 1) = " " Then pozitif = 1 Else pozitif = 0
a = Right(a, Len(a) - 1)

If Len(a) > 15 Then GoTo Hata
a = String(15 - Len(a), "0") + a

For x = 1 To 15
v(x) = Val(Mid(a, x, 1))
Next x

s = ""
For x = 0 To 4
c(1) = v(x * 3 + 1)
c(2) = v(x * 3 + 2)
c(3) = v(x * 3 + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "yüz"
Else
e = b(c(1)) + "yüz"
End If
e = e + y(c(2)) + b(c(3))
If e = "" Then e = e + m(x)
If (x = 3) And (e = "birbin") Then e = "bin"
s = s + e
Next x

If s = "" Then s = "sıfır"
If pozitif = 0 Then s = "eksi" + s

Cevir = UCase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1)
End Function
Exit Sub
Hata:
Cevir = "HATA"
End Function



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub


If Intersect(Target, [E8]) Is Nothing Then Exit Sub
If Range("E8") <> "" Then
Range("M6") = Range("M6") + 1
End If
End Sub

Selamlar
Ben sizin dosyanızda kullandım sıkıntı yok.
siz kullandığınız yukarıdaki kodlarda kırmızı renkli End Sub kısmını silerek deneyiniz.

İndir

 

[iska1]

Selamlar
Ben sizin dosyanızda kullandım sıkıntı yok.
siz kullandığınız yukarıdaki kodlarda kırmızı renkli End Sub kısmını silerek deneyiniz.

İndir

Selamlar Hocam. Kod çalıştı çok teşekkür ederim elinize sağlık. Eğer vaktinizi almayacaksa son bir isteğim daha olacak.
Aynı kodu kullanarak veri doğrulama hücresini değil de butona atayarak veya normal yoldan "Dışa Aktar" yaptığımda +1 yapabilir miyiz? "Dışa Aktar" yaptığımızda aynı zamanda x hücredeki isimle kaydedebilir miyiz?

Tecrübelerinizi aktararak, en önemlisi kıymetli vaktinizi ayırarak yardımcı olduğunuz için tekrar teşekkür ederim.

 

[Mdemir63]

Selamlar

İnceleyiniz

 

[iska1]

Selamlar
Hocam çok çok sağ olun emeğiniz için teşekkür ederim, j
İnceleyiniz

Selamlar

İnceleyiniz

Hocam çok çok sağ olun emeğiniz için teşekkür ederim, hakkınızı helal edin.

 

[Mdemir63]

Selamlar
Rica ederim . Helal olsun.
İyi çalışmalar