TL ve KR ayırma ve toplama

[sirkülasyon]

Hayırlı Sabahlar.
Müsait olan ustalarımdan makro konusunda istirhamım olacak.

TL kısmı için :
H6 hücresine 100,25 yazdığım zaman 25 KR' yi I6 hücresine atacak
H7 hücresine 150,75 yazdığım zaman 75 KR' yi I7 hücresine atacak
Bu işlem 33 üncü satıra kadar devam edecek.
34 üncü satırda ise;
H34 hücresine TL toplamını I34 hücresine de KR toplamını alacak.

Yardımcı olacak arkadaşlara şimdiden teşekkürü bir borç bilir saygılarımı sunarım.

H6:H33 TL kısmı
I6:I33 KR kısmı

H34 TL Toplamı
I34 KR toplamı

 

[hamitcan]

Bu şekilde dener misiniz ?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 8 Then Exit Sub
    a = Int(Target)
    b = Format(Target - Int(a), "0.00")
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
End Sub

 

[sirkülasyon]

Hamit Abi
Kr kısmını örneğin 111,11 TL yi 0,11 olarak atıyor.
Birde toplama yapmıyor abi.

 

[Orion1]

Böyle deneyin.

b = (Target - a)*100

 

[sirkülasyon]

Evren Abi Hayırlı Akşamlar.
Kr kısmı tamam.

Eğer Müsaitseniz H34 hücresine TL tutarlarının toplamını I34 hücresine de KR toplamlarını aldırabilecek makro için rica etsem yardımcı olabilir misiniz?

 

[Orion1]

Buyurun.

Range("H34").Value = WorksheetFunction.Sum(Range("H6:H33"))
Range("I34").Value = WorksheetFunction.Sum(Range("I6:I33"))

 

[sirkülasyon]

Evren Abi Özür dilerim.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 8 Then Exit Sub
    a = Int(Target)
    b = (Target - a)*100
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
End Sub

Kodu ile Tl ve Kr ayırma tamam. Bu koda ilaveten H34 hücresine TL toplamı ve I34 hücresine Kr toplamı alacağım. Kr hücresinde artan TL kısmını da TL hücresine aktaracak.

Mümkünse bu kod için (tamamı tek makroda olacak şekilde) yardımcı olabilir misiniz?

 

[vardar07]

Hamitcan Bey'in ve Orion1 Bey'in kodlarının birleştirilmiş hali.

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range("H1:H33")) Is Nothing Then Exit Sub  
    a = Int(Target)
    b = (Target - a)*100
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
Range("H34").Value = WorksheetFunction.Sum(Range("H6:H33"))
Range("I34").Value = WorksheetFunction.Sum(Range("I6:I33"))
End Sub

 

[sirkülasyon]

http://dosya.web.tr/RJ2mkR

TOPLAM kısmına toplamayı yaptıramadım.

 

[vardar07]

Dosyanız bozuk. Tekrar yükleyiniz

 

[Ömer BARAN]

TOPLAMA işlemi için buyurunuz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H6:I33")) Is Nothing Then Exit Sub
Cells(34, 9) = 100 * ((WorksheetFunction.Sum(Range("I6:I33")) / 100) - (Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)))
Cells(34, 8) = WorksheetFunction.Sum(Range("H6:H33")) + Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)
End Sub

 

[sirkülasyon]

tekrar yükledim.

 

[sirkülasyon]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H6:I33")) Is Nothing Then Exit Sub
Cells(34, 9) = 100 * ((WorksheetFunction.Sum(Range("I6:I33")) / 100) - (Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)))
Cells(34, 8) = WorksheetFunction.Sum(Range("H6:H33")) + Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)
End Sub

kodu toplamayı gerçekleştiriyor.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 8 Then Exit Sub
    a = Int(Target)
    b = (Target - a)*100
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
End Sub

kodu da tl ve kr yi ayırıyor.

İki kodu sıkıntısız çalıştırmam için birleştirme de yardımcı olabilir misiniz?

 

[vardar07]

Dosyanızdaki kodun en alttaki yeşil yazılı satırların başındaki tırnak işaretlerini kaldırırsanız toplama yapıyor. Yani 8 nolu mesajdaki gibi yaparsanız tamamdır.

 

[sirkülasyon]

üstad
13 üncü mesajdaki kodları birleştire bilir misiniz?

 

[vardar07]

Buyurun.

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range("H1:H33")) Is Nothing Then Exit Sub
    a = Int(Target)
    b = Format(Target - Int(a), "0.00") * 100
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
Cells(34, 9) = 100 * ((WorksheetFunction.Sum(Range("I6:I33")) / 100) - (Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)))
Cells(34, 8) = WorksheetFunction.Sum(Range("H6:H33")) + Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)
End Sub

 

[sirkülasyon]

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range("H1:H33")) Is Nothing Then Exit Sub
    a = Int(Target)
    b = Format(Target - Int(a), "0.00") * 100
    Target = a
    Cells(Target.Row, Target.Column + 1) = b
Cells(34, 9) = 100 * ((WorksheetFunction.Sum(Range("I6:I33")) / 100) - (Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)))
Cells(34, 8) = WorksheetFunction.Sum(Range("H6:H33")) + Int(WorksheetFunction.Sum(Range("I6:I33")) / 100)
End Sub

Hayırlı Akşamlar;
Mustafa Bey;
makro kodunu uyguladığım zaman

If Intersect(Target, Range("H1:H33")) Is Nothing Then Exit Sub

kısmı sürekli hata veriyor. Bakabilmeniz mümkün mü?

Teşekkür ederim. Saygılarımla

 

[Ömer BARAN]

Merhaba.
Aşağıdaki şekilde dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If WorksheetFunction.CountBlank(Range("H6:H33")) = WorksheetFunction.CountBlank(Range("I6:I33")) Then Exit Sub
If Intersect(Target, Range("H6:H33")) Is Nothing Then Exit Sub
    If Int(Target) = Target Then
        Cells(Target.Row, Target.Column + 1) = 0 + Format(0, "0.00"): Target = Target
        Exit Sub
    Else
        Cells(Target.Row, 9) = 0 + 100 * Format((Target - Int(Target)), "0.00"): Target = Int(Target)
    End If
    Cells(34, 9) = (WorksheetFunction.Sum(Range("I6:I33"))) - (100 * Int(WorksheetFunction.Sum(Range("I6:I33")) / 100))
    Cells(34, 8) = WorksheetFunction.Sum(Range("H6:H33")) + (Int(WorksheetFunction.Sum(Range("I6:I33")) / 100))
End Sub

 

[sirkülasyon]

Sayın Ömer BARAN Kardeşim.
Ellerine Sağlık. Makro kodu sıkıntısız olarak çalışmakta.
Teşekkür Ederim.

 

[Ömer BARAN]

Sayın Ömer BARAN Kardeşim.
Ellerine Sağlık. Makro kodu sıkıntısız olarak çalışmakta.
Teşekkür Ederim.

Eyvallah, Hekimhan'a selamlar.
Sağlıcakla.