Belirlenen Sayfalardaki Verileri Tek Sayfada Listelemek

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,432
Excel Vers. ve Dili
Ofis 2016

Merhaba Arkadaşlar,
Aşağıdaki kod ile TÜM SAYFALARDAKİ verileri tek sayfada listelemek mümkün.
Acaba TÜM SAYFALARI değil de G1:G5 alanında belirlenen sayfalardaki verileri aynı sayfada listelemek mümkün müdür ?


C++:
Sheets("Liste").Select
Range("B5:B" & Rows.Count).ClearContents
With CreateObject("Scripting.Dictionary")
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "LİSTE" Then
son = sh.Cells(Rows.Count, 3).Row
If son > 3 Then
For i = 4 To son
ky = sh.Cells(i, 3)
If ky <> "" Then .Item(ky) = Null
Next i
End If
End If
Next sh
kys = .keys
For i = 0 To UBound(kys)
Cells(i + 5, "B") = kys(i)
Next i
End With
End Sub


 
 
 

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
877
Excel Vers. ve Dili
office2010
Merhaba.

Kod:
Sheets("Liste").Select
Dim syf()
Range("B5:B" & Rows.Count).ClearContents
With CreateObject("Scripting.Dictionary")
syf = [G1:G5].Value
    For Each sh In ThisWorkbook.Worksheets
        For j = 1 To 5
            If syf(j, 1) <> "" Then
                If syf(j, 1) = sh.Name Then
                    son = sh.Cells(Rows.Count, 3).End(xlUp).Row
                    If son > 3 Then
                        For i = 4 To son
                            ky = sh.Cells(i, 3)
                            If ky <> "" Then .Item(ky) = Null
                        Next i
                    End If
                End If
            End If
        Next j
    Next sh
    kys = .keys
    For i = 0 To UBound(kys)
        Cells(i + 5, "B") = kys(i)
    Next i
End With
 
Son düzenleme:

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,432
Excel Vers. ve Dili
Ofis 2016
Merhaba.

Kod:
Sheets("Liste").Select
Range("B5:B" & Rows.Count).ClearContents
With CreateObject("Scripting.Dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "LİSTE" Then
            For i = 1 To 5
                ky = sh.Cells(i, 7)
                If ky <> "" Then .Item(ky) = Null
            Next i
        End If
    Next sh
    kys = .keys
    For i = 0 To UBound(kys)
        Cells(i + 5, "B") = kys(i)
    Next i
End With
Üstad teşekkür ederim. Ama bu kod sayfa isimlerini listeledi. Aradığımız çözüm, G1:G5 alanında isimleri yazılı sayfalardaki verileri Liste sayfasında birleştirmesi idi
 

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
877
Excel Vers. ve Dili
office2010
Üstad teşekkür ederim. Ama bu kod sayfa isimlerini listeledi. Aradığımız çözüm, G1:G5 alanında isimleri yazılı sayfalardaki verileri Liste sayfasında birleştirmesi idi
Kod düzenlendi tekrar deneyin.


*** Veri alırken ve yazdırmada durumunda dizi olarak tanımlanırsa işlemiz daha hızlı sonuç verir.
 

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,432
Excel Vers. ve Dili
Ofis 2016
Kod düzenlendi tekrar deneyin.


*** Veri alırken ve yazdırmada durumunda dizi olarak tanımlanırsa işlemiz daha hızlı sonuç verir.
Üstad çok teşekkür bu kod tamamdır. Acaba Birleştirme alanını "A2:D*" (* son satır) olacak şekilde nasıl değiştirmek gerekir acaba !
 

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
877
Excel Vers. ve Dili
office2010
Üstad çok teşekkür bu kod tamamdır. Acaba Birleştirme alanını "A2:D*" (* son satır) olacak şekilde nasıl değiştirmek gerekir acaba !
Örnek dosya olmadan varsayımla yazılan kod.

Kod:
Sub test()
Sheets("Liste").Select
Dim syf()
Application.ScreenUpdating = 0
Range("B5:D" & Rows.Count).ClearContents
With CreateObject("Scripting.Dictionary")
syf = [G1:G5].Value
ReDim b(1 To Rows.Count, 1 To 4)
For j = 1 To 5
If syf(j, 1) <> "" Then
On Error Resume Next
Set sh = Sheets(syf(j, 1))
If Err = 0 Then
    son = sh.Cells(Rows.Count, 3).End(xlUp).Row
    If son > 1 Then
        a = sh.Range("A2:D" & son).Value
        For i = 1 To UBound(a)
            ky = a(i, 3)
            If Not .exists(ky) Then
                .Item(ky) = .Count + 1
                say = .Count
                For x = 1 To UBound(a, 2)
                    b(say, x) = a(i, x)
                Next x
            End If
        Next i
    End If
End If
On Error GoTo 0
End If
Next j
If say > 0 Then
    [B5].Resize(say, 4) = b
End If
End With
Application.ScreenUpdating = 1
End Sub
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
28,812
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Üstte ki mesajımda ki dosya revize edildi.

3 farklı yöntemle çözüm uygulandı.
 

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,432
Excel Vers. ve Dili
Ofis 2016
Alternatif;

3 yöntem uygulandı.
  • ADO Yöntemi
  • Dizi Yöntemi
  • Kopyala-Yapıştır Yöntemi
Korhan Ayhan üstadım, ilginize, desteğinize ve her bir yöntem için çok teşekkür ediyorum. 3'ü de harikulade kodlar. Çok hızlı çalışıyorlar. Emeğinize, aklınıza sağlık, sağlıcakla kalın.
 
Üst