Liste Alma

[jajiyiko]

Merhaba!
Herkese kolay gelsin.

Benim sayfa1 'de listem var. Liste şu şekilde;

A sütunu B sütunu C Sütunu

Grup No Yılı Miktar
12345 2017 8
14368 2015 12
12345 2016 9
14368 2018 22

gibi..


Ben başka bir sayfaya;

Grup No 2015 Yılı 2016 yılı 2017 yılı 2018 yılı
12345 9 8
14368 12 22


bu şekilde yapmak istiyorum.
Teşekkür ederim

Selam ve saygılarımla

 

[Ziynettin]

Merhaba,

Sayfa1 verilerin olduğu sayfa,
Sayfa2 istenilen sonuç sayfanız.

Sub tablo()
  Set s1 = Sheets("Sayfa1")
  Set s2 = Sheets("Sayfa2")
  a = s1.Range("A2:C" & s1.Cells(Rows.Count, 1).End(xlUp).Row).Value
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  ReDim b(1 To UBound(a), 1 To UBound(a))
    For i = 1 To UBound(a)
        krt1 = CStr(a(i, 1))
        If Not d1.exists(krt1) Then
            d1(krt1) = d1.Count + 1
            sat = d1.Count
        End If
        sat = d1(krt1)
        krt2 = CStr(a(i, 2))
        If Not d2.exists(krt2) Then
            d2(krt2) = d2.Count + 1
            sut = d2.Count
        End If
        sut = d2(krt2)
        b(sat, sut) = b(sat, sut) + CDbl(a(i, 3))
    Next i
    Application.ScreenUpdating = False
    s2.Cells.Clear
    s2.[A2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    s2.[B1].Resize(1, d2.Count) = d2.keys
    s2.[B2].Resize(d1.Count, d2.Count) = b
    s2.[A1].Resize(d1.Count + 1, d2.Count + 1).Borders.Color = 1
   
    s2.[A2].Resize(d1.Count, d2.Count + 1).Sort key1:=s2.[A2], _
        Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlSortColumns

    s2.[B1].Resize(d1.Count + 1, d2.Count).Sort key1:=s2.[B1], _
        Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlSortRows
    Application.ScreenUpdating = t
    s2.Select
End Sub

 

[jajiyiko]

Merhaba!
Sayın Ziynettin;
İlginize teşekkür ederim.

ReDim b(1 To UBound(a), 1 To UBound(a))

satırında "out of memory" hatası veriyor. Bendeki dosyada çok sayıda ( 9000 civarı kayıt var )

ondan mıdır acaba?

100 , 200 kayıtta sorunsuz çalışıyor.
saygılar