satırdaki değişkenleri saydırma

[regdtee]

merhaba,

ekte gönderdiğim dosyada a ve b sütunundaki bilgilerden hemen yan tarafa oluşturduğum tabloyu özet tablo kullanmadan macro ile oluşturmak istiyorum.

iyi çalışmalar..

 

[hamitcan]

Aşağıdaki linki inceleyin.
http://www.excel.web.tr/f60/topla-c...-vba-icindeki-farkli-kullanimlari-t82178.html

 

[regdtee]

teşekkür ederim ilginize ama ordan pek bişey çıkaramadım konuya pek hakim değilim

 

[Orion1]

Dosyanızı 2003 formatında yükleyin.

 

[regdtee]

ekledim prdon

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub meyveler_59()
Dim z As Object, myarr(), liste(), n As Long, a As Long, i As Long, sat As Long
Dim isim As String, sut As Integer, meyve As String
Sheets("Sayfa1").Select
Range("D4:H65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = Range("A2:B" & sat)
ReDim myarr(1 To 5, 1 To sat)
For i = 1 To UBound(liste)
    isim = UCase(Replace(Replace(liste(i, 1), "ı", "I"), "i", "İ"))
    If Not z.exists(isim) Then
        n = n + 1
        z.Add isim, n
        myarr(1, n) = liste(i, 1)
    End If
    meyve = UCase(Replace(Replace(liste(i, 2), "i", "İ"), "ı", "I"))
    If meyve = "ELMA" Then
        sut = 2
        ElseIf meyve = "KAVUN" Then
        sut = 3
        ElseIf meyve = "KİRAZ" Then
        sut = 4
        ElseIf meyve = "PORTAKAL" Then
        sut = 5
        Else
        MsgBox meyve & " Kayıtlarda Yok."
        GoTo atla
    End If
    myarr(sut, z.Item(isim)) = myarr(sut, z.Item(isim)) + 1
atla:
Next
    Erase liste
    Set z = Nothing
    Application.ScreenUpdating = False
    Range("D3").Resize(n, 5) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[regdtee]

çok teşekkür ederim elinize kolunuza sağlık..