Aynı döngü içinde 3 dizi oluşturma

[antonio]

Herkese Merhaba,
Ekte örnek dosyada görüleceği üzere, elimde Sayfa1 de, TEOG Yerleştirme sonuçlarına göre 11 ortaokuldan toplam 382 öğrencinin 13 farklı lise türüne yerleşme verileri var.
İstediğim: Sayfa2 de "A2:A12" sütun aralığına benzersiz ortaokul isimleri, "B1:N1" satır aralığına da benzersiz lise türleri gelecek şekilde bir tablo oluşturarak bunlara karşılık gelen (hangi ortaokuldan hangi lise türüne kaçar öğrenci yerleştiği) verileri dizi mantığı ile tespit edebilmektir.
Aşağıdaki kodlarla oluşturmak istediğim tablonun dikey ve yatay verilerini tek boyutlu dizilerle oluşturabiliyorum. Fakat öğrenci sayılarını vermesini istediğim üçüncü diziyi aynı döngü içinde oluşturma mantığını çözemedim. İlgilenen arkadaşlara şimdiden teşekkürler...
Üzerinde çalıştığım kodlar:

Sub durumu_analiz_et()
Dim s1 As Worksheet, s2 As Worksheet, ss As Long, dx(), dy(), dizi()
Dim a

Set s1 = Sayfa1
Set s2 = Sayfa2
ss = s1.Range("A" & Rows.Count).End(3).Row
a = s1.Range("A2:C" & ss)

ReDim dizi(1 To 1, 1 To 1)
ReDim dx(1 To 1, 1 To 1)
ReDim dy(1 To 1, 1 To 1)

s2.Range("1:1, A:A").ClearContents
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        okul = a(i, 1)
        yer = a(i, 3)
        durum = okul & "#" & yer
                If Not .exists(okul) Then
                    .Add okul, x
                    x = x + 1
                    ReDim Preserve dx(1 To 1, 1 To x)
                    dx(1, x) = okul
                End If
                If Not .exists(yer) Then
                    .Add yer, y
                    y = y + 1
                    ReDim Preserve dy(1 To 1, 1 To y)
                    dy(1, y) = yer
                End If
'        '===================================
'        ReDim dizi(1 To x, 1 To y)
'        dizi(x, y) = y
'        '===================================
    Next i
End With
s2.Activate
s2.Range("B1").Resize(1, y).Value = dy
s2.Range("A2").Resize(x, 1).Value = Application.Transpose(dx)
s2.Range("B2").Resize(x, y).Value = Application.Transpose(dizi)
End Sub

 

[Ziynettin]

Merhaba,

Anladğım Ortaokuldan liseye yerleşen öğrenci sayısını bulmak ise bu kodu deneyin.

Option Explicit
Sub analiz()
Dim a(), b(), d1 As Object, d2 As Object
Dim Sat As Long, Sut As Long, Say1 As Long, Say2 As Long, i As Long
Sheets("Sayfa1").Select
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Sat = 1
Sut = 1
Say1 = Sat
Say2 = Sut
a = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        If d1.exists(a(i, 1)) Then
            Sat = d1(a(i, 1))
        Else
            d1(a(i, 1)) = Say1
            Sat = Say1
            Say1 = Say1 + 1
        End If
        If d2.exists(a(i, 3)) Then
            Sut = d2(a(i, 3))
        Else
            d2(a(i, 3)) = Say2
            Sut = Say2
            Say2 = Say2 + 1
        End If
        ReDim Preserve b(1 To UBound(a), 1 To d2.Count)
        b(Sat, Sut) = b(Sat, Sut) + 1
    Next i
    
    With Sheets("Sayfa2")
        .Cells.ClearContents
        .Range("A2").Resize(d1.Count) = Application.Transpose(d1.keys)
        .Range("B1").Resize(, d2.Count) = d2.keys
        .Range("B2").Resize(d1.Count, d2.Count) = b
        .Select
    End With
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[antonio]

Ziynettin Bey, beyninize sağlık. Kodlarınız sorunsuz çalışıyor ve doğru sonuç veriyor. Çok teşekkür ederim.

 

[Ziynettin]

Rica ederim.
İyi çalışmalar.