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
 
Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...
Korhan bey Emeklerinize sağlık.
Sonuç sayfasına TC kimlik numarası Adı soyadı ve mükerrer ayları yazacak şekilde revize edebilir miyiz. Şimdiden teşekkürler.
 
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 Ad_Soyad As String
    Dim Temp As Variant
    Dim K As Variant
    Dim P1 As Long
    Dim P2 As Long
    Dim Adet As Long

    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:C" & Last_Row).Value2
                    For X = 1 To UBound(Data, 1)
                        TC = Trim$(CStr(Data(X, 1)))
                        Ad_Soyad = Trim$(CStr(Data(X, 2)))
                        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

                                    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

                                ' İsim boşsa ilk bulunan ismi koru
                                If Len(Temp(2)) = 0 And Len(Ad_Soyad) > 0 Then
                                    Temp(2) = Ad_Soyad
                                End If

                                TC_Kontrol(TC) = Temp
                            Else
                                ' 0 = Dosya/Sayfa/Adet
                                ' 1 = Farklı Dosya/Sayfa Sayısı
                                ' 2 = Ad Soyad

                                TC_Kontrol.Add TC, _
                                    Array( _
                                        XFile & "\" & Ws.Name & "(1)", _
                                        1, _
                                        Ad_Soyad)
                            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 3)

    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(2)
            Result(No, 3) = 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:C1").Value = Array( _
        "TC No", _
        "Ad Soyad", _
        "Dosya/Sayfa/Adet")

    If No > 0 Then
        Sh.Range("A2").Resize(No, 3).Value = Result
        Sh.Columns("A:C").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
 
Hocam; ReDim Result(1 To TC_Kontrol.Count, 1 To 3) bu satırda subscript out of range hatası aldım.
 
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 Ad_Soyad As String
    Dim Konum As String
    Dim Temp As Variant
    Dim K As Variant
    Dim P1 As Long
    Dim P2 As Long
    Dim Adet As Long
    Dim ErrMsg As String

    Dim OldCalc As XlCalculation
    Dim OldScreen As Boolean
    Dim OldEvents As Boolean
    Dim OldAlerts As Boolean
    Dim OldLinks As Boolean

    On Error GoTo Hata

    With Application
        OldScreen = .ScreenUpdating
        OldCalc = .Calculation
        OldEvents = .EnableEvents
        OldAlerts = .DisplayAlerts
        OldLinks = .AskToUpdateLinks

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

    Set TC_Kontrol = CreateObject("Scripting.Dictionary")
    TC_Kontrol.CompareMode = vbTextCompare

    File_Folder = ThisWorkbook.Path & "\"
    XFile = Dir(File_Folder & "*.xls*")

    Do While XFile <> ""

        If XFile <> ThisWorkbook.Name And Left$(XFile, 2) <> "~$" 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:C" & Last_Row).Value2

                    Konum = XFile & "\" & Ws.Name

                    For X = 1 To UBound(Data, 1)

                        TC = Trim$(CStr(Data(X, 1)))
                        Ad_Soyad = Trim$(CStr(Data(X, 2)))

                        If Len(TC) > 0 Then

                            If TC_Kontrol.Exists(TC) Then

                                Temp = TC_Kontrol(TC)

                                ' Toplam tekrar sayısı
                                Temp(1) = Temp(1) + 1

                                ' Aynı sayfada daha önce var mı?
                                P1 = InStr(1, Temp(0), _
                                    "|" & Konum & "(", vbTextCompare)

                                If P1 > 0 Then

                                    ' Mevcut sayfanın adetini artır
                                    P2 = InStr(P1, Temp(0), ")")

                                    Adet = CLng(Mid$( _
                                        Temp(0), _
                                        P1 + Len("|" & Konum & "("), _
                                        P2 - P1 - Len("|" & Konum & "(")))

                                    Temp(0) = Replace( _
                                        Temp(0), _
                                        "|" & Konum & "(" & Adet & ")", _
                                        "|" & Konum & "(" & Adet + 1 & ")")

                                Else

                                    ' Yeni dosya/sayfa konumu
                                    Temp(0) = Temp(0) & _
                                        "|" & Konum & "(1)"

                                End If

                                ' İlk bulunan boş olmayan ismi güncelle
                                If Len(Temp(2)) = 0 And Len(Ad_Soyad) > 0 Then
                                    Temp(2) = Ad_Soyad
                                End If

                                TC_Kontrol(TC) = Temp

                            Else

                                ' 0 = Dosya/Sayfa/Adet
                                ' 1 = Toplam kayıt sayısı
                                ' 2 = Ad Soyad

                                TC_Kontrol.Add TC, Array( _
                                    "|" & Konum & "(1)", _
                                    1, _
                                    Ad_Soyad)

                            End If

                        End If

                    Next X

                End If

            Next Ws

            Wb.Close False
            Set Wb = Nothing

        End If

        XFile = Dir

    Loop

    ' Mükerrer TC sayısını hesapla
    For Each K In TC_Kontrol.Keys

        Temp = TC_Kontrol(K)

        If Temp(1) > 1 Then No = No + 1

    Next K

    ' Sonuç dizisini oluştur
    If No > 0 Then

        ReDim Result(1 To No, 1 To 3)

        No = 0

        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(2)

                ' Dosya/Sayfa bilgilerini düzenle
                Result(No, 3) = Replace( _
                    Mid$(Temp(0), 2), "|", " - ")

            End If

        Next K

    End If

    ' Eski raporu sil
    On Error Resume Next
    ThisWorkbook.Worksheets("Mükerrer_TC").Delete
    On Error GoTo Hata

    ' Yeni rapor oluştur
    Set Sh = ThisWorkbook.Worksheets.Add
    Sh.Name = "Mükerrer_TC"

    Sh.Range("A1:C1").Value = Array( _
        "TC No", _
        "Ad Soyad", _
        "Dosya/Sayfa/Adet")

    If No > 0 Then
        Sh.Range("A2").Resize(No, 3).Value = Result
    End If

    Sh.Columns("A:C").AutoFit

Safe_Exit:

    On Error Resume Next

    If Not Wb Is Nothing Then Wb.Close False

    Set TC_Kontrol = Nothing

    With Application
        .ScreenUpdating = OldScreen
        .Calculation = OldCalc
        .EnableEvents = OldEvents
        .DisplayAlerts = OldAlerts
        .AskToUpdateLinks = OldLinks
    End With

    On Error GoTo 0

    If Len(ErrMsg) > 0 Then
        MsgBox ErrMsg, vbCritical
    Else
        MsgBox No & " adet mükerrer TC bulundu.", vbInformation
    End If

    Exit Sub

Hata:

    ErrMsg = "Hata No: " & Err.Number & vbCrLf & _
             "Açıklama: " & Err.Description

    Resume Safe_Exit
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst