Tablo Oluştur, Seçime Göre, Diğer Sayfadan

[1Al2Ver]

Merhaba,

Açılır Kutu'dan yapılacak seçime göre;

İlk 15 veri için bir TABLO oluşmasını arzuluyorum,

Oluşacak Tablo , Sayfa1, "B1" den seçilene göre, yine Sayfa1'de "A4:C18" aralığında olmalı,

Alınacak Veriler, Sayfa2, "B1:GT82" aralığındadır,

İstenenler, ek'li dosyada örneklenmiştir. Teşekkür ederim.

 

[YUSUF44]

Aşağıdaki kodları Sayfa1'in kod bölümüne yapıştırıp deneyiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    Set s1 = Sheets("Sayfa2")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    [A4:C18].ClearContents
    If Target = "" Then GoTo 10
    sut = WorksheetFunction.Match(Target, s1.[A1:GT1], 0)
    yeni = 4
    For sat = 2 To son
        If s1.Cells(sat, sut) <> "" Then
            Cells(yeni, "A") = yeni - 3
            Cells(yeni, "B") = s1.Cells(sat, "B")
            Cells(yeni, "C") = s1.Cells(sat, sut)
            yeni = yeni + 1
            If yeni > 18 Then GoTo 10
        End If
    Next
10:
Application.ScreenUpdating = True
End Sub

 

[1Al2Ver]

Sayın YUSUF44 merhaba,

Duyarlığınız ve çözüm için, çok teşekkür ederim,

Saygılarımla.

 

[1Al2Ver]

Sayın YUSUF44 tekrar merhaba,

Cevap yazarken, sayısal değerlerin en büyük ilk 15'inin tabloda yer almasını dikkatlice incelememişim,

İlk 15 diyerek yaptığım hata için özür dilerim,

Kod, 81 ilin verilerinde, "Sayfa2" nin ilgili sütunundaki verilerin, en yüksek 15 tanesini, il'e göre tabloya aktarmalı,

Kod'da revizeyi rica ediyorum.

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    Set s1 = Sheets("Sayfa2")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    [A4:C18].ClearContents
    If Target = "" Then GoTo 10
    sut = WorksheetFunction.Match(Target, s1.[A1:GT1], 0)
    yeni = 4
    For sat = 2 To son
        If s1.Cells(sat, sut) <> "" Then
            Cells(yeni, "A") = yeni - 3
            Cells(yeni, "B") = s1.Cells(sat, "B")
            Cells(yeni, "C") = s1.Cells(sat, sut)
            yeni = yeni + 1
        End If
    Next
    yeni = Cells(Rows.Count, "B").End(3).Row
    ActiveWorkbook.Worksheets("Sayfa1").ListObjects("Tablo3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").ListObjects("Tablo3").Sort.SortFields.Add2 _
        Key:=Range("Tablo3[VERİLER]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").ListObjects("Tablo3").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    If yeni > 18 Then
        Range("A19:C" & yeni).Delete shift:=xlUp
    End If
    For j = 18 To 4 Step -1
        If Cells(j, "B") <> "" Then
            Cells(j, "A") = j - 3
        Else
            Range("A" & j & ":C" & j).Delete shift:=xlUp
        End If
    Next
10:
Application.ScreenUpdating = True
End Sub

 

[1Al2Ver]

Sayın YUSUF44 merhaba,

Öncelikle çözümler için teşekkür ederim, sağ olun.

"Sayfa1" e, A4:C18 deki verilerden oluşan bir HARİTA ekledim, B1 değiştikçe harita verileri de değişsin, görsellik olsun amacıyla,

"Sayfa1" B1'den seçim yaptığımda, makro dosyayı kapatıp çıkıyor,

Ek'li dosyada örnekledim, bakabilirseniz memnun olurum,

Tekrar teşekkür ederim.

 

[YUSUF44]

Ekli dosyayı inceleyiniz. Yardımcı olarak Sayfa3'ü kullandım. Harita işi güzelmiş bu arada, ilk defa gördüm

 

[1Al2Ver]

Sayın YUSUF44 merhaba,

Gayet güzel çalışıyor, emeğinize sağlık, teşekkür ederim.

Her şey için tekrar sağ olun.

Saygılarımla.

Not ; Modül1'deki kodun bir işlevselliği yok sanırım...

 

[YUSUF44]

Evet yok, kod elde etmek için makro kaydet kullanıyorum, o kodlardır.