Birden fazla sayfadan veri sorgulama

  • Konbuyu başlatan Konbuyu başlatan evren28
  • Başlangıç tarihi Başlangıç tarihi
E

evren28

Katılım
17 Ağustos 2009
Mesajlar
55
Excel Vers. ve Dili
2007
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.
 

Ekli dosyalar

evren28' Alıntı:
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.
Genişletmek için tıkla ...

.

ÖZET TABLOLAR (PİVOT TABLE)

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

.
 
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
 
evren28' Alıntı:
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
Genişletmek için tıkla ...

.

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...

..
 
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
 
Merhaba,

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

C++: 
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
 
Çok Teşekkürler Korhan bey; emeğinize sağlık yarına deneyeceğim.
 
Hocam çok teşekkürler. tam istediğim gibi,
Bu sayfaların her birinin ayrı bir dosya olduğunu ve hepsinin bir klasörde olduğunu kabul etsek, o şekilde sorgulama imkanı olabilir mi?
 
Deneyiniz.

C++: 
Option Explicit

Sub Mukerrer_TC_Kontrol_Folder()
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim Sh As Worksheet
    Dim TC_Kontrol As Object
    Dim Data As Variant
    Dim Result() As Variant
    Dim File_Folder As String
    Dim XFile As String
    Dim Last_Row As Long
    Dim X As Long
    Dim No As Long
    Dim TC As String
    Dim Temp As Variant
    Dim K As Variant

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

    Set TC_Kontrol = CreateObject("Scripting.Dictionary")

    File_Folder = ThisWorkbook.Path & "\"

    XFile = Dir(File_Folder & "*.xls*")

    Do While XFile <> ""
        If XFile <> ThisWorkbook.Name Then
            Set Wb = Workbooks.Open( _
                Filename:=File_Folder & XFile, _
                ReadOnly:=True, _
                UpdateLinks:=False)

            For Each Ws In Wb.Worksheets
                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) & "-", _
                                    "-" & XFile & "\" & Ws.Name & "(", _
                                    vbTextCompare) > 0 Then

                                    Dim P1 As Long
                                    Dim P2 As Long
                                    Dim Adet As Long

                                    P1 = InStr(1, _
                                        Temp(0), _
                                        XFile & "\" & Ws.Name & "(", _
                                        vbTextCompare)

                                    P2 = InStr(P1, Temp(0), ")")

                                    Adet = CLng(Mid$( _
                                        Temp(0), _
                                        P1 + Len(XFile & "\" & Ws.Name & "("), _
                                        P2 - P1 - Len(XFile & "\" & Ws.Name & "(")))

                                    Temp(0) = Replace( _
                                        Temp(0), _
                                        XFile & "\" & Ws.Name & "(" & Adet & ")", _
                                        XFile & "\" & Ws.Name & "(" & Adet + 1 & ")")
                                Else
                                    Temp(0) = Temp(0) & _
                                              "-" & _
                                              XFile & "\" & Ws.Name & "(1)"

                                    Temp(1) = Temp(1) + 1
                                End If
                                TC_Kontrol(TC) = Temp
                            Else
                                TC_Kontrol.Add TC, _
                                    Array(XFile & "\" & Ws.Name & "(1)", 1)
                            End If
                        End If
                    Next X
                End If
            Next Ws
            Wb.Close False
        End If
        XFile = Dir
    Loop

    ReDim Result(1 To TC_Kontrol.Count, 1 To 2)

    For Each K In TC_Kontrol.Keys
        Temp = TC_Kontrol(K)
        If Temp(1) > 1 Then
            No = No + 1
            Result(No, 1) = K
            Result(No, 2) = Temp(0)
        End If
    Next K

    On Error Resume Next
    Worksheets("Mükerrer_TC").Delete
    On Error GoTo 0

    Set Sh = Worksheets.Add
    Sh.Name = "Mükerrer_TC"
    Sh.Range("A1:B1").Value = Array("TC No", "Dosya/Sayfa/Adet")

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

Safe_Exit:

    Set TC_Kontrol = Nothing

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

    MsgBox No & " adet mükerrer TC bulundu.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst