Veri Al, Sayfalardan, 2 Seçeneğe Göre

[1Al2Ver]

Merhaba,

"Rapor" isimli sayfaya ,

Ay isimlerinin olduğu sayfalardan, Ay (A1) ismine ve 2 nci bir seçeneğe (C1) göre verileri,almak istiyorum.

Teşekkür ederim.

 

[Ziynettin]

Merhaba,

Kodu rapor sayfası kod alanına yapıştırın.
A1 den sayfa adını seçiniz.
C1 den anket konusu seçildiğinde verileriniz listelenir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "C1" Then
On Error Resume Next
sh = [A1]
Set s1 = Sheets(sh)
son_sut = s1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
son_sat = s1.Columns(2).Find("*", , , , xlByRows, xlPrevious).Row

Err = 0
sut = WorksheetFunction.Match(Trim(Target), s1.[D1].Resize(, son_sut), 0) + 3
If Err = 0 Then
Set d = CreateObject("scripting.dictionary")
a = s1.Range("B2").Resize(son_sat, son_sut + 4).Value
ReDim b(1 To UBound(a), 1 To son_sut + 4)
For i = 1 To UBound(a)
    say = say + 1
    d(a(i, 1)) = say
    b(say, 1) = a(i, 2)
    For y = 1 To 5
        b(say, y + 1) = a(i, sut - 2 + y)
    Next y
Next i
say = 0
c = Range("C5:C" & Cells(Rows.Count, 3).End(3).Row).Value
ReDim v(1 To UBound(c), 1 To 6)
For i = 1 To UBound(c)
    say = say + 1
    For y = 1 To 6
        v(say, y) = b(d(c(i, 1)), y)
    Next y
Next i
[D5].Resize(say, 6) = v
Else

MsgBox "Anket bulunamadı", vbCritical
End If
On Error GoTo 0
End If
End Sub

 

[1Al2Ver]

Sayın Ziynettin, merhaba,

Güzel emeğiniz ve çözümünüz için teşekkür ederim, sağ olun.

Tekrar teşekkür ederim.

 

[Ziynettin]

Tekrar deneyiniz. Kod güncellendi.

 

[1Al2Ver]

Sayın Ziynettin merhaba,

Yardımlarınız ve emekleriniz için bir kez daha teşekkür ederim, sağ olun.

Saygılarımla.