Soru Verileri Tablo Haline getirmek

[hadromer]

MErhaba,
fotoğraftaki gibi A ve B sütunlarından oluşan verilerim var.

A sütunundaki Başlığa kodların B sütununda karşılık geldiği veriyi oluşturmak istediğim tabloya çekmek istiyorum. Örnek veriler ve oluşturmak istediğim tabloya ait dosya ektedir. Yardımcı olabilir misiniz ? Teşekkür ederim.

km_kare_alanlar.xlsx dosyasını indir - download

km_kare_alanlar.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s5.dosya.tc

 

[hadromer]

düşeyara formülü ile sorunum çözülmüştür.

 

[Ziynettin]

Deneyiniz...

Sub test()
Application.ScreenUpdating = False
Set s1 = Sheets("alınacak veri")
son = s1.Cells(Rows.Count, 1).End(3).Row
a = s1.Range("A1:B" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
        If Not Application.IsError(a(i, 2)) Then
            say = say + 1
            If Left(a(i, 2), 4) = "Land" Then
                b(say, 1) = a(i, 1)
            Else
                b(say, 2) = a(i, 1)
                b(say, 3) = Format(a(i, 2), "#,##0.00%")
            End If
            If b(say, 1) <> "" Then y1 = b(say, 1)
            krt = y1 & "#" & b(say, 2)
            dc(krt) = b(say, 3)
        End If
    End If
Next i

say = 0
son = 0
Set s2 = Sheets("tablo")
son = s2.Cells(Rows.Count, 1).End(3).Row
c = s2.Range("A1:X" & son).Value
ReDim v(1 To UBound(c), 1 To UBound(c, 2))
For i = 2 To UBound(c)
    say = say + 1
    For j = 2 To UBound(c, 2)
        krt = c(i, 1) & "#" & c(1, j)
        If dc.exists(krt) Then
            v(say, j - 1) = dc(krt)
        End If
    Next j
Next i
s2.[B2].Resize(say, UBound(c, 2) - 1) = v
Application.ScreenUpdating = True
MsgBox "İşlem Bitti...", vbInformation
End Sub

 

[hadromer]

Deneyiniz...

Sub test()
Application.ScreenUpdating = False
Set s1 = Sheets("alınacak veri")
son = s1.Cells(Rows.Count, 1).End(3).Row
a = s1.Range("A1:B" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
        If Not Application.IsError(a(i, 2)) Then
            say = say + 1
            If Left(a(i, 2), 4) = "Land" Then
                b(say, 1) = a(i, 1)
            Else
                b(say, 2) = a(i, 1)
                b(say, 3) = Format(a(i, 2), "#,##0.00%")
            End If
            If b(say, 1) <> "" Then y1 = b(say, 1)
            krt = y1 & "#" & b(say, 2)
            dc(krt) = b(say, 3)
        End If
    End If
Next i

say = 0
son = 0
Set s2 = Sheets("tablo")
son = s2.Cells(Rows.Count, 1).End(3).Row
c = s2.Range("A1:X" & son).Value
ReDim v(1 To UBound(c), 1 To UBound(c, 2))
For i = 2 To UBound(c)
    say = say + 1
    For j = 2 To UBound(c, 2)
        krt = c(i, 1) & "#" & c(1, j)
        If dc.exists(krt) Then
            v(say, j - 1) = dc(krt)
        End If
    Next j
Next i
s2.[B2].Resize(say, UBound(c, 2) - 1) = v
Application.ScreenUpdating = True
MsgBox "İşlem Bitti...", vbInformation
End Sub

çok teşekkür ederim çok güzel çalışıyor.
Bir istirhamım daha olabilir mi acaba ? Kodlar gördüğünüz üzere 1-5 arası başlıyor. O kodlar aslında 1.2.5 veya 5.1.1 gibi yazarak kullanıyoruz. sizin hazırladıgınız tablo ayrıntılı tabloydu. Birde bunun özele indirgenmiş hali var. 1 ile başlayanlar şehir alanları başlığı altında, 2 ile başlayanlar tarım alanları gibi. Bu tablonun bir de bu şekilde aktarılabileceği halini hazırlayabilir misiniz ? Alınacak veri sekmesindeki tüm 1 ile başlayan kodlar Şehir alanlarına, 2 ile başlayan tarım alanlarına, 3 ile başlayan Ormanlık alanlara 5 ile başlayanlar da sulak alanlara gelecek. ben bir örnek format hazırladım. Kontrol eder misiniz ?

ozet_Tablo.xlsx dosyasını indir - download

ozet_Tablo.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s5.dosya.tc

 

[hadromer]

Ziynettin Bey,
son mesajımdaki isteğime gerek kalmadı. Ben data consolid yaptım oldu. Teşekkür ederim