Soru tablolardan veri çekip başka tabloda birleştirme

[nes432]

merhaba,

aşağıdaki linkte bir excel dosyam var tek tabloda veri birleştirmek istiyorum. Açıklama dosyada mevcut.

yardımcı olacak arkadaşlara şimdiden teşekkürler

http://s7.dosya.tc/server14/la4se3/deneme_-_K.xlsx.html

 

[veyselemre]

Sub listele()
    Dim w(1 To 1, 1 To 11)
    With CreateObject("Scripting.Dictionary")
        For Each sh In ThisWorkbook.Sheets
            If sh.Name Like "Tab*" Then
                son = sh.Cells(Rows.Count, 2).End(3).Row
                For i = 2 To son Step 17
                    say = 0
                    For ii = 1 To 15
                        Select Case ii
                            Case 4, 7, 10, 13
                            Case Else
                                say = say + 1
                                w(1, say) = sh.Cells(i + ii, 3).Value
                        End Select
                    Next ii
                    .Item(sh.Cells(i, 2).Value) = w
                Next i

            End If
        Next sh
        Set s1 = Sheets("Ana")
        For i = 4 To s1.Cells(Rows.Count, 3).End(3).Row
            If .exists(s1.Cells(i, 3).Value) Then
                s1.Cells(i, 4).Resize(, 11).Value = .Item(s1.Cells(i, 3).Value)
            End If
        Next i
    End With
End Sub

 

[nes432]

Sub listele()
    Dim w(1 To 1, 1 To 11)
    With CreateObject("Scripting.Dictionary")
        For Each sh In ThisWorkbook.Sheets
            If sh.Name Like "Tab*" Then
                son = sh.Cells(Rows.Count, 2).End(3).Row
                For i = 2 To son Step 17
                    say = 0
                    For ii = 1 To 15
                        Select Case ii
                            Case 4, 7, 10, 13
                            Case Else
                                say = say + 1
                                w(1, say) = sh.Cells(i + ii, 3).Value
                        End Select
                    Next ii
                    .Item(sh.Cells(i, 2).Value) = w
                Next i

            End If
        Next sh
        Set s1 = Sheets("Ana")
        For i = 4 To s1.Cells(Rows.Count, 3).End(3).Row
            If .exists(s1.Cells(i, 3).Value) Then
                s1.Cells(i, 4).Resize(, 11).Value = .Item(s1.Cells(i, 3).Value)
            End If
        Next i
    End With
End Sub

teşekkür ediyorum harika olmuş