Satırda toplam işlemi nasıl olabilir.

[command]

ekte örneği yükledim. satır satır toplama işi nasıl yapılabilir.

yardımcı olabilirseniz çok sevinirim.

tşkler.

 

[command]

arkadaşlar bu benim için çok önemli bir olay, yardım ederseniz sevinirim.

 

[Necdet]

Merhaba,

Kodları deneyiniz.

Sub Topla()
    Dim i       As Long, _
        j       As Integer, _
        Toplam  As Long, _
        Deg     As String, _
        USD     As Currency, _
        EUR     As Currency, _
        s, _
        ss
    USD = [B1]
    EUR = [C1]
    For i = 2 To Cells(Rows.Count, "a").End(3).Row
        Deg = Trim(Replace(Cells(i, "A"), ".", ""))
        s = Split(Deg, Chr(10))
        Toplam = 0
        For j = 0 To UBound(s)
            ss = Split(s(j), " ")
            If UBound(ss) = 0 Then
                Toplam = Toplam + ss(0)
            Else
                If ss(1) = "USD" Then
                    Toplam = Toplam + ss(0) * USD
                ElseIf ss(1) = "EUR" Then
                    Toplam = Toplam + ss(0) * EUR
                Else
                    Toplam = Toplam + ss(0)
                End If
            End If
        Next j
        Cells(i, "D") = Toplam
    Next i

    MsgBox "Hesaplama Bitmiştir....", vbInformation, "N. YEŞERTENER [URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]"
    
End Sub

Kodların dosya açılışında otomatik çalışması için ThisWorkbookun kod sayfasında aşağıdaki kodların olması yeterlidir.

Private Sub Workbook_Open()
    Topla
End Sub

 

[command]

Hocam Allah razı olsun, çok güzel düşünmüş yazmışsın. tam istediğim gibi olmuş. Zihnine sağlık

Fakat bir sorum olabilir mi?

Her açılışta otomatik çalışması için ne yapmam gerekir, birde A sütununda hücrede boş satır olması durumunda(tutar yazan yerde boşluk varsa) "If ss(1) = "USD" Then" ile ilgili hata veriyor. bunu nasıl geçebiliriz.

 

[command]

demek istediğimin örneği ekte.

 

[Necdet]

Merhaba,

Mesajımdaki kodları ve dosyayı yeniledim, tekrar inceler misiniz?

 

[Necdet]

Tekrar merhaba,

Otomatik çalışmasını unutmuşum, kodlar ve dosya yenilendi.

 

[command]

Hocam ellerinize sağlık, mükemmel olmuş.

Tekrar teşekkürler.

 

[command]

Mrb hocam,

Daha önce çok güzel bir kod yazmıştınız. Fakat şimdi aynı mantıkta sadece 2 seçeneğe göre toplama işlemine ihtiyacım var.

Örnekte olduğu gibi,

A sütununda gayrinakdi yazanları ve yazmayanları aynı mantıktan ayrı sütunlara toplayacağız.

Yardımcı olabilirseniz çok sevinirim.

 

[Necdet]

Merhaba,

Sub ToplamAl()
Dim i       As Long, _
    j       As Integer, _
    dz1()   As String, _
    dz2()   As String, _
    dz3()   As String, _
    ToplamG As Double, _
    ToplamN As Double, _
    Ayrac   As String, _
    Dol     As Currency, _
    Eur     As Currency
Application.ScreenUpdating = False
Sheets("2.").Select
Dol = Range("G1")
Eur = Range("H1")
Ayrac = Chr(10)
For i = 2 To Cells(Rows.Count, "A").End(3).Row
    If Not Cells(i, "A") = "" And Not Cells(i, "C") = "" Then
        dz1 = Split(Application.WorksheetFunction.Trim(Cells(i, "A")), Ayrac)
        dz2 = Split(Replace(Application.WorksheetFunction.Trim(Cells(i, "C")), ".", ""), Ayrac)
 
        ToplamG = 0
        ToplamN = 0
 
        For j = 0 To UBound(dz1)
            If Not dz1(j) = "" Then
                dz3 = Split(dz2(j), " ")
                If dz1(j) Like "G*" Then
                    If dz3(1) Like "U*" Then
                        ToplamG = ToplamG + (dz3(0) * Dol)
                    ElseIf dz3(1) Like "E*" Then
                        ToplamG = ToplamG + (dz3(0) * Eur)
                    Else
                        ToplamG = ToplamG + dz3(0)
                    End If
                Else
                    If dz3(1) Like "U*" Then
                        ToplamN = ToplamN + (dz3(0) * Dol)
                    ElseIf dz3(1) Like "E*" Then
                        ToplamN = ToplamN + (dz3(0) * Eur)
                    Else
                        ToplamN = ToplamN + dz3(0)
                    End If
                 End If
            End If
        Next j
 
        Cells(i, "D") = ToplamG
        Cells(i, "E") = ToplamN
 
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Toplamlar Alınmıştır....", vbInformation, "N. YEŞERTENER [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[command]

Valla ne diyeceğimi bilmiyorum, ellerinize sağlık, çok çok teşekkür ediyorum.

Saygılarımla hocam.

 

[Necdet]

Merhaba,

Güle güle kullanınız. Saygı bizden.