aynılarını birleştirip toplamlarını çıkarma

[halit3]

aranan = yer1 & yer2 & yer3 & yer4

yukarıdaki kodu aşağıdaki ile değiştirin

aranan = yer2 & yer3 & yer4

 

[ozki85]

oldu şimdi tşk ederim ufak tefek aynılarından vardı onlarıda elle birleştirdim

 

[halit3]

oldu şimdi tşk ederim ufak tefek aynılarından vardı onlarıda elle birleştirdim

iyi çalışmalar

 

[ozki85]

merhaba arkadaşlar,

buna benzer bişey daha var, fakat biraz değişiklik yaptım kodlarda olmadı. Size gönderiyorum bi bakarmısınız.

istenilenler:
zip içinde 3 dosya var 2008-2009-2010 diye şimdi: a sütununda firmalar var, b sütununda markalar var, c sütununda ise fiyatlar var.
Hangi firma hangi markadan kaç para satmış bunlar hesaplanacak
örnek
NBG ÇORAP İML.SAN.VE TİC.A.Ş. ADAMS £12,79
NBG ÇORAP İML.SAN.VE TİC.A.Ş. NEXT £321,70

bunun gibi
her yıl ayrı ayrı olacak birde hepsi birleşmiş olarak olacak, yani 2 dosya olacak

teşekkür ederim

 

[ozki85]

konu ile ilgili bişey yok mu

 

[Orion1]

Sorunuzun ilk bölümünü yaptım.
Bunu inceleyin.
Olmuşsa genekl toplamları byaradn alıcan.
Dosyayı ekledim.
Dosya Evren_59
Diğer dostyalarla ayni klasöede olamalıdır.

Option Explicit

Option Base 1

Sub firamalar_59()
Dim z As Object, yil As String, a(), n As Long, myarr()
Dim sh As Worksheet, fso As Object, f As Object, ds As Object, sat As Long
Dim sat2 As Long, i As Long, deg As String, son_sat As Long
Sheets("Yillik").Select
Range("A2:D65536").ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path).Files
sat = 2
Application.ScreenUpdating = False
For Each ds In f
    If ds.Name <> ThisWorkbook.Name Then
        If Workbooks.Open(ds).ReadOnly = True Then Workbooks(ds.Name).Close
        'Workbooks(ds.Name).Sheets(1).AutoFilter
        sat2 = Workbooks(ds.Name).Sheets(1).Cells(65536, "A").End(xlUp).Row
        If sat2 > 1 Then
            a = Workbooks(ds.Name).Sheets(1).Range("A2:C" & sat2).Value
            Workbooks(ds.Name).Close False
            Set z = CreateObject("Scripting.Dictionary")
            ReDim myarr(1 To 3, 1 To sat2)
            For i = 1 To UBound(a, 1)
                deg = a(i, 1) & "-" & a(i, 2)
                If deg <> "" Then
                    If Not z.exists(deg) Then
                        n = n + 1
                        z.Add deg, n
                        myarr(1, n) = a(i, 1)
                        myarr(2, n) = a(i, 2)
                    End If
                    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + a(i, 3)
                End If
            Next i
            son_sat = ThisWorkbook.Sheets(1).Cells(65536, "A").End(xlUp).Row + 1
            ThisWorkbook.Sheets(1).Range("A" & son_sat).Resize(n, 1) = Left(ds.Name, 4)
            ReDim Preserve myarr(1 To 3, 1 To n)
            ThisWorkbook.Sheets(1).Range("B" & son_sat).Resize(n, 3) = Application.Transpose(myarr)
            Set z = Nothing
            n = 0
            Erase myarr: Erase a
        End If
    End If
Next ds
Set fso = Nothing: Set f = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Yıl - Firma ismi - Marka bazında Ayrışıp Toplandı." & _
vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[ozki85]

özür dileyerek söylüyorum tabloda değişiklik oldu ekte gönderdiğim gibi olacak umarım açık bir şekilde anlaşılır

 

[ozki85]

çözüm yok mu arkadaşlar