Birden fazla sayfadan veri sorgulama

[evren28]

Arkadaşlar kolay gelsin. Formda yeniyim.
Ekte gönderdiğim dosyada yapmak istediğimşey şu;
yaklaşık 40 - 45 sayfadan oluşan bir excel dosyam var ve bu sayfalardaki verileri kullanarak bir raporlama sayfası oluşturmak istiyorum. raporlama sayfasındaki kriterleri kullanarak diğer sayfalardan veri çekmek ve sadece o sayfayı yazdırmak istiyorum. böyle birşey mümkünmüdür. örnek ekte. Şimdiden teşekkürler.

 

[Merhum İdris SERDAR]

Arkadaşlar kolay gelsin. Formda yeniyim.
Ekte gönderdiğim dosyada yapmak istediğimşey şu;
yaklaşık 40 - 45 sayfadan oluşan bir excel dosyam var ve bu sayfalardaki verileri kullanarak bir raporlama sayfası oluşturmak istiyorum. raporlama sayfasındaki kriterleri kullanarak diğer sayfalardan veri çekmek ve sadece o sayfayı yazdırmak istiyorum. böyle birşey mümkünmüdür. örnek ekte. Şimdiden teşekkürler.

.

ÖZET TABLOLAR (PİVOT TABLE)

Burada 32 No'lu mesajımda eklediğim örneği inceleyin.

.

 

[evren28]

yurttaş hocam verdiğiniz bilgiler çok güzel ancak uygulamak istediğimde "Bu veri kaynağı görünür tablolar içermiyor" diye hata veriyor

 

[Merhum İdris SERDAR]

yurttaş hocam verdiğiniz bilgiler çok güzel ancak uygulamak istediğimde "Bu veri kaynağı görünür tablolar içermiyor" diye hata veriyor

.

Sayfalarınız aynı sütun başlıkları ile veri tabanı mantığı çerçevesinde hazırlanması gerekir.

Tıpkı örnek dosyada olduğu gibi...

..

 

[unur]

Mrb;
Tüm sayfalardan sorgulama yapıp mükerrer bulunan Tc kimlik numarası bulunması durumunda sayfa adlarını mesaj olarak yazdırabilir miyiz?
Teşekkürler

 

[Korhan Ayhan]

Merhaba,

Mükerrer sayısı fazla olursa listeleme konusunda MsgBox yetersiz kalabilir. Bu sebeple ben sonuçları "Mükerrer_TC" isimli bir sayfada listeledim.

Option Explicit

Sub Mukerrer_Tc_No_Kontrol()
    Dim Ws As Worksheet
    Dim Sh As Worksheet
    Dim TC_Kontrol As Object
    Dim Data As Variant
    Dim Result() As Variant
    Dim Last_Row As Long
    Dim X As Long
    Dim No As Long
    Dim TC As String
    Dim Temp As Variant

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    Set TC_Kontrol = CreateObject("Scripting.Dictionary")

    ReDim Result(1 To 1000, 1 To 2)

    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name <> "Mükerrer_TC" Then
            Last_Row = Ws.Cells(Ws.Rows.Count, "B").End(xlUp).Row
            If Last_Row >= 2 Then
                Data = Ws.Range("B2:B" & Last_Row).Value2
                For X = 1 To UBound(Data, 1)
                    TC = Trim$(CStr(Data(X, 1)))
                    If Len(TC) > 0 Then
                        If TC_Kontrol.Exists(TC) Then
                            Temp = TC_Kontrol(TC)
                            If InStr(1, "-" & Temp(0) & "-", _
                                       "-" & Ws.Name & "-", vbTextCompare) = 0 Then
                                Temp(0) = Temp(0) & "-" & Ws.Name
                                If Temp(1) = 0 Then
                                    No = No + 1
                                    If No > UBound(Result, 1) Then
                                        ReDim Preserve Result(1 To No + 1000, 1 To 2)
                                    End If

                                    Result(No, 1) = TC
                                    Result(No, 2) = Temp(0)
                                    Temp(1) = No
                                Else
                                    Result(Temp(1), 2) = Temp(0)
                                End If
                                TC_Kontrol(TC) = Temp
                            End If
                        Else
                            TC_Kontrol.Add TC, Array(Ws.Name, 0)
                        End If
                    End If
                Next
            End If
        End If
    Next

    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Mükerrer_TC").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set Sh = Worksheets.Add
    Sh.Name = "Mükerrer_TC"

    Sh.Range("A1:B1").Value = Array("TC No", "Bulunduğu Sayfalar")

    If No > 0 Then
        Sh.Range("A2").Resize(No, 2).Value = Result
        Sh.Columns("A:B").AutoFit
    End If

    Set TC_Kontrol = Nothing

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    MsgBox No & " adet mükerrer TC bulundu.", vbInformation
End Sub