aynı degerleri bul ve hesapla(kdv)

[uguristanbul]

sayın hocalarım ve degerli arkadaslar
ekteki dosyadan da anlasılacagı gibi bir kdv makrosu yazmaya calıstım basaramadım
ozet olarak sorun soyle:
n sutununda kdv oranları ve s sutunundada tutarlar var
n sutnunda benzer verileri a sutununa yazacak ve karsılıgına gelens sutunundaki verileri toplayı b sutununa yacak c sutunda a sutunu ile b sutununu carpıp yuze bolecek ve c sutununu toplayıp d2 ye yazacak
yardım edecek arkadaslarıma simdiden tesekkur ederim
cok karısık anlatmıs olabilirim ama dosyayı incelerseniz daha basit oıldugunu anlayacagınıza eminim
saygılarımla

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub HESAPLA()
Dim SUT, S As Integer
[A2:D100].Clear
S = 1
For SUT = 2 To Cells(65536, "N").End(3).Row
If Not WorksheetFunction.CountIf(Range("N1:N" & SUT), Cells(SUT, "N")) > 1 Then
S = S + 1
Cells(S, "A") = Cells(SUT, "N")
End If
Next
S = 1
For SUT = 2 To Cells(65536, "A").End(3).Row
S = S + 1
Cells(S, "B") = WorksheetFunction.SumIf(Range("N2:N65536"), Cells(SUT, "A"), Range("S2:S65536"))
Next
S = 1
For SUT = 2 To Cells(65536, "A").End(3).Row
S = S + 1
Cells(S, "C") = Cells(SUT, "A") * Cells(SUT, "B") / 100
Next
[D2] = WorksheetFunction.Sum(Range("C2:C65536"))
End Sub

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu standart bir modül sayfasına kopyalayıp çalıştırınız.

Option Explicit
Sub KDV_Hesabi()
    Dim col As New Collection
    Dim arrV()
    Dim i As Integer
    Dim x As Integer
    Dim j As Integer
    
    On Error Resume Next
    
    For i = 2 To Cells(65536, "N").End(xlUp).Row
        
[COLOR=darkgreen]        'KDV oranları koleksiyona alınıyor[/COLOR]
        col.Add CStr(Cells(i, "N")), CStr(Cells(i, "N"))
        
[COLOR=darkgreen]        'Eğer hata değeri alınmamışsa
        'Benzersiz veriler, ilk defa diziye alınıyor[/COLOR]
        If Err.Number = 0 Then
            x = x + 1
            ReDim Preserve arrV(1 To 4, 1 To x)
            arrV(1, x) = Cells(i, "N")
            arrV(2, x) = Cells(i, "S")
            arrV(3, x) = Cells(i, "N") * Cells(i, "S") / 100
            arrV(4, 1) = arrV(3, x) + arrV(4, 1)
        
[COLOR=darkgreen]        'Bir hata ile kaşılaşılmışsa,
        'bu veri daha önce koleksiyonda ve dolayısıyla dizide vardır
        'Onun için dizide ilgili eleman bulunup
        'karşısındaki değer güncelleniyor[/COLOR]
        Else
            
            For j = 1 To UBound(arrV, 2)
                If Cells(i, "N") = arrV(1, j) Then
                    arrV(2, j) = arrV(2, j) + Cells(i, "S")
                    arrV(3, j) = arrV(3, j) + (Cells(i, "S") * arrV(1, j) / 100)
                    arrV(4, 1) = arrV(4, 1) + arrV(3, j)
                    Exit For
                End If
            Next j
[COLOR=darkgreen]            'Hata değeri, yeni değerlendirme için sıfırlanıyor[/COLOR]
            Err.Number = 0
        End If
    Next i
    
    On Error GoTo 0
    
[COLOR=darkgreen]    'Derlenen verilerin yazdırılacağı alan temizleniyor[/COLOR]
    Range("A2:D" & Cells(65536, 1).End(xlUp).Row).ClearContents
    
[COLOR=darkgreen]    'Veriler sayfaya yazdırılıyor[/COLOR]
    Range("A2").Resize(UBound(arrV, 2), _
                       UBound(arrV, 1)) = Application.WorksheetFunction.Transpose(arrV)
    
End Sub

 

[yeniyetme]

yukarıda verilen kodda aşağıda yazdığım satırlar mükemmel şekilde iş görüyor ama ben bir türlü anlayamadım if ile başlayan satırın bana tam olarak açılımını yapabilecek bir arkadaş varmı acaba? yani ne olabilir eğer n sutununda şu şu şuna şu olduğu için gibi falan işte. ve özelliklede >1 ne anlama geliyor.

For SUT = 2 To Cells(65536, "N").End(3).Row
If Not WorksheetFunction.CountIf(Range("N1:N" & SUT), Cells(SUT, "N")) > 1 Then
S = S + 1
Cells(S, "A") = Cells(SUT, "N")
End If
Next

 

[uguristanbul]

sorun devam ediyor

degerli hocalarım
iyi ki varsınız oncelikle verdiginiz kodlarda baslıbasına calısmakta ancak ben asagıdaki dosyaya uyarlayamadım
şöyle
ekteki dosyada veri sayfasından formu ac diyoruz acılan formdan(anamen&#252 faturayı ac diyoruz(basliksizform)2 nci form açılınca yukarda belirtmiş oldugum kod checkbox3 (R:FATURA) işaretlenmis ise çalısmalı checkbox4(grFATURA) işaretli ise subdan cıkmalı
acıkolan formda ürün bilgileri gir frame ine gelip bilgi girince ekle butonu ile fatura sayfasına aktarıyor ve altındaki listbox9 da sayfadan bilgileri alıyor ama göndermiş oldugunuz kodları ben bu dosyaya uyarlayamadım
ilk sorumda sorunumu tam olarak anlatmadığım için özür diler
saygılar sunarım
ve gercekten yardımlarınızı en acil şekilde beklidiğimi belirtmek isterim
ilgilenecek arkadaslarıma sunu da belirtmek isterim
listbox 9 a cift tıklandıgında satırı siliyor
eğer boyle bir durumoldugunda da silinen satırın kdv oran ve tutarlarını düşmeli yazılacak olan kod