Metin İfadeye göre diğer sütunu toplama

[arzum2000]

Ekteki dosyada A sütununda üretim tipi´B sütununda ise tiplere göre ürün boyları vardır.Yapmak istediğim ancak yapamadığım şey ise a sütununda ki sayısal ifadeyle başlayan tüm ürün tiplerinin en sondaki metin ifadeye göre aynı olan metinleri ürün tiplerine göre d:I sütunu arasında toplamını almak.A ve B sütunlarını ExecuteExcel4Macro ile başka dosyadan alıyorum aynı makronun sonuna ekleme yapılabilirse daha iyi olur.Yardımlarınız için şimdiden teşekkür ediyorum.Saygılarımla.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub VERİ_AL()
    Dim i As Long, son As Long, sat As Long, j As Byte
 
    Sheets("verial").Select
 
    Application.ScreenUpdating = False
 
    Range("A4:B65536").ClearContents
    Range("D4:I4").ClearContents
 
    son = Application.ExecuteExcel4Macro("COUNTA('" & ThisWorkbook.Path & "\[veriler.xls]aylık'!C1)") + 2
    sat = 3
 
    For i = 3 To son
 
        Cells(sat, "A").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[veriler.xls]aylık'!R" & i & "C1")
        Cells(sat, "B").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[veriler.xls]aylık'!R" & i & "C15")
 
        For j = 4 To 9
            If Cells(sat, "A") <> Empty Then
                If HARFAYIR(Cells(sat, "A")) <> "" Then
                    If Cells(3, j) = HARFAYIR(Cells(sat, "A")) Then
                        Cells(4, j) = Cells(4, j) + Cells(sat, "B")
                    End If
                End If
            End If
        Next
 
        sat = sat + 1
 
    Next
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function HARFAYIR(Hücre As Range)
    Dim X As Integer
    For X = 1 To Len(Hücre)
        If Not IsNumeric(Mid(Hücre, X, 1)) Then SONUÇ = SONUÇ & Mid(Hücre, X, 1)
    Next
 
    SONUÇ = IIf(SONUÇ = 0, "", SONUÇ)
    HARFAYIR = SONUÇ
End Function

 

[arzum2000]

Elinize sağlık Korhan bey teşekkürlerimi iletiyorum.