birleştirilmiş fatura nosunu ve tutarını ayırma

[mavisachal]

Arkadaslar selam,

Oncelikle bu soruya herkesin kendine gore farkli bir bakis acisi getirecegini dusunuyorum ve en guzel ve en sade olarak nasil yapılabilir acaba diye soruyu sizinle paylaşmak istiyorum.

Sorum şudur,

Ornek.xls dosyasında A kolonunda fatura numarası ve B kolonunda tutarları mevcuttur. Bunlar gercek tutarlardır. E kolonunda ise gelen fatura numarası vardır ki bunu gonderen sistem goruldugu gibi 2-3 faturayı birlestirip gondermektedir yani demek istedigim E2 hucresinde 40203080 ve 40203082 olmak uzere 2 fatura vardir ve bunların toplamı F hucresinde gorunmektedir. Bunun gibi dusunun 40000 falan satır oldugunu tek tek tutarlar eşit mi diye kontrol etmek ugras ugras bitmez.

Peki boyle bir seyi makro ile ya da formul ile nasil yapabiliriz. Amacım E kolonundaki faturaları normal sekilde yazdirmak ve bunları A kolonundan buldurup B kolonundaki tutarları toplayıp F kolonundaki ile eşit mi degil mi ona bakip aradaki farkı yazdırmak.

Umarım anlaşılır olmustur. Bunun icin fikirlerinizi bekliyorum arkadaslar.

Tesekkurler.

 

[mavisachal]

yok mu arkadaslar bir fikri olan?

 

[uzmanamele]

merhaba
ilk alternatif çözüm benden olsun, başka çözüm yolları önerilecektir

 

[Necdet]

Merhaba,

Bende makrolu bir çözüm önereyim. Sonucu G sütununa yazdırdım, sizin örnek ile tutup tutmadığını anlamak için, doğru çalışırsa siz kırmızı ile yazılan hücre referansını değiştirebilirsiniz.

Not : Bu gün soruyu gördüğümde güzel bir soru dedim, ama işyerinde fazla vaktim olmadığı için pek ilgilenemedim. Demek istemem şu ki, acele etmemek gerek.

Sub Topla()
Dim Toplam As Double
Dim i, Deger As Long
Dim j As Integer
Application.ScreenUpdating = False
 
For i = 2 To [E65536].End(3).Row
    a = Split(Cells(i, "E"), "-")
    Toplam = 0
    For j = 0 To UBound(a)
         If j = 0 Then
            Deger = a(j)
        Else
            Deger = Left(a(0), Len(a(0)) - Len(a(j))) + a(j)
        End If
 
        With Range("a:a")
            Set Bul = .Find(Deger, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Bul Is Nothing Then
                Toplam = Toplam + Cells(Bul.Row, "B")
            End If
        End With
    Next j
    Cells(i, "[B][COLOR=red]G[/COLOR][/B]") = Toplam
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[mavisachal]

Arkadaslar,
Oncelikle zaman ayirdiginiz ve fikirler sunup yardimci oldugunuz icin cok tesekkur ederim.

Sayın Necdet Yeşertener,

Dosyayı biraz kompleksleştirdim daha dogrusu gelen fatura çeşitliligini ekledim. Çalıştırdığım sırada bir hata verdi bunu anlayamadim aynı şekilde ekliyorum dosyayı.
Bunun dışında acaba oluşturulan faturaları yandaki hucrelere yazdırabilir miyiz acaba? (Bunu da ornek olsun diye ikinci satır için dosyada gönderdim)

Tabi ki soruya farklı bakış açıları getirenler olacaktir. Burada amacımız en kolay ve kullanılır olan çözümü bulmak. kaldı ki hata götürmeyecek bir iş gerçekten.

 

[uzmanamele]

merhaba
10530321904 nolu fatura listede olmadığından hata veriyor, gelen fatura listesini doğru doldurmalısınız.

not:
benim önerdiğim formülü kullanacaksanız YERİNEKOY fonksiyonunu DEĞİŞTİR fonksiyonu olarak düzeltiniz.

 

[mavisachal]

Selam uzmanamele,

Tesekkur ederim ancak ekledigim zaman da baktim ayni hatayi verdi ekteki dosyada bunu gorebilirsin. Acikcasi birde gelen faturalar kisminda olupta yanlış yazılmış ve Fatura No sutununda olmayan'da olabilir bunu da goz ardi etmemek lazim yani bunda da hata vermeyecek sekilde belki orda hatayi atlatabiliriz. Bilemiyorum tabi ki.

Senin formule gelince acikcasi makro ile eklentilere ekleyerek makro calistirmak daha isime gelir Makro ile cozum olmazsa manual olarak soyledigin formatı dusuneceğim. Tesekkurler.

 

[mavisachal]

Pardon yeni dosyayi eklemeyi unuttum yukardaki msgimda

 

[Necdet]

Merhaba,

Deger değişkenini Double yapınca hata düzeldi. Ouşturulan faturaların yan hücrelere yazdırmak içinde kırmızı ile belirtilen komutları kullandım.

Sub Topla()
Dim Toplam, [B][COLOR=red]Deger [/COLOR][/B]As Double
Dim i As Long
Dim j, [B][COLOR=red]Kolon [/COLOR][/B]As Integer
Application.ScreenUpdating = False

For i = 2 To [E65536].End(3).Row
    a = Split(Cells(i, "E"), "-")
    Toplam = 0
    Kolon = 7
    For j = 0 To UBound(a)
        If j = 0 Then
            Deger = a(j)
        Else
            Deger = Left(a(0), Len(a(0)) - Len(a(j))) + a(j)
        End If
        
        [COLOR=red][B]Kolon = Kolon + 1
        Cells(i, Kolon) = Deger[/B][/COLOR]
        
        With Range("a:a")
            Set Bul = .Find(Deger, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Bul Is Nothing Then
                Toplam = Toplam + Cells(Bul.Row, "B")
            End If
        End With
    Next j
    Cells(i, "G") = Toplam
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[uzmanamele]

merhaba
pişmiş aşa su katılmaz ama aşağıdaki satırı ekleseniz iyi olur.

Range("g:l").ClearContents

 

[Necdet]

aklımdan geçtiydi de unutmuşum

 

[mavisachal]

Arkadaslar,
fatura Numarasında harf olmasindan mıdır bilmem boyle olunca hata verdi elimdeki dosyada sadece bu hucreler icin hata aldim ekledigimi dosyada kırmızı ile gosterdim.
Bunun sebebi ne olabilir?

 

[Necdet]

Halledelim o zaman.

Sub Topla()
Dim Toplam As Double
Dim i As Long
Dim j, Kolon As Integer
[COLOR=red][B]Dim Deger As String[/B][/COLOR]
Application.ScreenUpdating = False
Range("G2:Z65536").ClearContents
For i = 2 To [E65536].End(3).Row
    a = Split(Cells(i, "E"), "-")
    Toplam = 0
    Kolon = 7
    For j = 0 To UBound(a)
        If j = 0 Then
            Deger = a(j)
        Else
            Deger = Left(a(0), Len(a(0)) - Len(a(j))) + a(j)
        End If
        
        Kolon = Kolon + 1
        Cells(i, Kolon) = Deger
        
        With Range("a:a")
            Set Bul = .Find(Deger, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Bul Is Nothing Then
                Toplam = Toplam + Cells(Bul.Row, "B")
            End If
        End With
    Next j
[COLOR=red]    If Toplam <> 0 Then
        Cells(i, "G") = Toplam
    Else
        Cells(i, "G") = "#YOK#"
    End If
[/COLOR]Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[mavisachal]

Sayın Necdet Yeşertener,
Cok guzel bir çalışma oldu simdi burda sormam gereken tek sey ise next i den once sona bir doevents eklesem mi eklemesem mi? Bu makro calisma aninda baska programlarla calismak gerekebilir ve bahsettigim dosyada yaklasik 50000 satir falan olacak ve bu calisma suresi uzun surebileceginden doevents yararı olur diye dusunuyorum siz ne dersiniz?
Cok cok Tesekkurler.