Birim kriterine göre topla aktar

[tahsinanarat]

Aşağıdaki kod ile ekli dosyada icmal alabiliyorum, benim yapmak istediğim F sütununda KL ise E sütunundaki miktarın gelmesi eğer PK ise E sütunundaki miktarın ikiye bölünerek aktarılmasını istiyorum. örn. ilk satırda 1232 PK olduğu için ikiye bölündüğünde 616 olarak toplayıp aktarmasını istiyorum. Yardımca olabilecek arkadaşlara şimdiden teşekkür ederim.

Sub AktarTopla()
Dim a, i As Long, b(), n As Long
Set s1 = Sheets("Sayfa1")
Set S2 = Sheets("İcmal")
veri = Array(1, 2)
Application.ScreenUpdating = False
S2.Range("A2:AB65536") = ""
'Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With s1.Range("a2").CurrentRegion.Resize(, 25)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 25)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
                n = n + 1
                .Add a(i, 1), n
                For Each s In veri
                    b(n, s) = a(i, s)
                Next
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 5)
          b(.Item(a(i, 1)), 4) = b(.Item(a(i, 1)), 4) + a(i, 22)
          b(.Item(a(i, 1)), 5) = b(.Item(a(i, 1)), 5) + a(i, 23)
          b(.Item(a(i, 1)), 6) = b(.Item(a(i, 1)), 6) + a(i, 24)
          b(.Item(a(i, 1)), 7) = b(.Item(a(i, 1)), 7) + a(i, 25)
          b(.Item(a(i, 1)), 8) = b(.Item(a(i, 1)), 8) + a(i, 24) + a(i, 25)
         
     Next
End With
With S2.Range("a1")
     .CurrentRegion.Resize(, 3).ClearContents
     .Resize(n, 25).Value = b
End With
Application.ScreenUpdating = True
S2.Select
sil
[A2:Z65536].Sort Key1:=[A2]
alttoplam
'MsgBox "Bitti"
Set s1 = Nothing
Set S2 = Nothing
End Sub

 

[veyselemre]

 End If
            
[COLOR="Red"][B]            If a(i, 6) = "PK" Then a(i, 5) = a(i, 5) / 2[/B][/COLOR]
            b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 5)

 

[tahsinanarat]

Sn. veyselemre hocam, kırmızı olan kod satırını ilave edip alttaki satırı kaldırdığımda doğru sonuç alıyorum, çok teşekkür ediyorum, elinize sağlık

 

[veyselemre]

Her iki satırda kalacak.

 

[tahsinanarat]

o zaman uygulamalı denediğimde fazla KL. çıkartıyor hocam. Evde sakin kafayla tekrar tetkik edip bildireceğim.

 

[tahsinanarat]

Sn. veyselemre hocam, şimdi denedim,

If a(i, 6) = "PK" Then a(i, 5) = a(i, 5) / 2
            b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 5)

olduğunda çıkması gereken toplam tam iki katına çıkıyor. Bilginize.

 

[tahsinanarat]

           If a(i, 6) = "PK" Then a(i, 5) = a(i, 5) / 2
           If a(i, 6) = "KL" Then a(i, 5) = a(i, 5)

Yukarıdaki şekilde yaptım, doğru sonuç aldım hocam. Teşekkür ederim.

 

[veyselemre]

           If a(i, 6) = "PK" Then a(i, 5) = a(i, 5) / 2
           If a(i, 6) = "KL" Then a(i, 5) = a(i, 5)

Yukarıdaki şekilde yaptım, doğru sonuç aldım hocam. Teşekkür ederim.

Alttaki satır gereksiz işlem, zaten varsayılan değer "KL"; değilse değiştireceksiniz.
a(i, 5) = a(i, 5) gereksiz.