Farklı sayfadaki verileri tek sayfada listelemek

[abnur]

Merhaba,

Farklı sayfada olan verileri Özet sayfasında listelemek istiyorum. Konuyla ilgili yardımınız rica ederim.

 

[ÖmerBey]

Merhaba,
Örnek dosyanız için deneyiniz...

Sub kod()
Dim say As Integer, a As Integer
Dim s1 As Worksheet, s2 As Worksheet
Dim trf As String, S As String, M As String, T As String

sayfa = Array("AA", "BB", " CC")

Set s1 = Sheets("ÖZET")
trf = s1.Range("A2").Value

For Each syf In sayfa
    Set s2 = Sheets(syf)
    say = say + WorksheetFunction.CountIf(s2.Range("F:F"), trf)
Next

ReDim dz(1 To say, 1 To 3)

For Each syf In sayfa
    Set s2 = Sheets(syf)
    For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
        If s2.Cells(a, "B") <> "" Then
            S = s2.Cells(a, "B").Value
            M = s2.Cells(a, "C").Value
            T = s2.Cells(a, "D").Value
        End If
        If s2.Cells(a, "F") = trf Then
            x = x + 1
            dz(x, 1) = S
            dz(x, 2) = M
            dz(x, 3) = T
        End If
    Next
Next
s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)).ClearContents
s1.Range("B2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

 

[abnur]

Merhaba,
Örnek dosyanız için deneyiniz...

Sub kod()
Dim say As Integer, a As Integer
Dim s1 As Worksheet, s2 As Worksheet
Dim trf As String, S As String, M As String, T As String

sayfa = Array("AA", "BB", " CC")

Set s1 = Sheets("ÖZET")
trf = s1.Range("A2").Value

For Each syf In sayfa
    Set s2 = Sheets(syf)
    say = say + WorksheetFunction.CountIf(s2.Range("F:F"), trf)
Next

ReDim dz(1 To say, 1 To 3)

For Each syf In sayfa
    Set s2 = Sheets(syf)
    For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
        If s2.Cells(a, "B") <> "" Then
            S = s2.Cells(a, "B").Value
            M = s2.Cells(a, "C").Value
            T = s2.Cells(a, "D").Value
        End If
        If s2.Cells(a, "F") = trf Then
            x = x + 1
            dz(x, 1) = S
            dz(x, 2) = M
            dz(x, 3) = T
        End If
    Next
Next
s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)).ClearContents
s1.Range("B2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Bunu excel ekledim fakat bir sonuç alamadım. Ekli halde iletmeniz mümkün müdür ?

 

[ÖmerBey]

Buyurunuz...

 

[abnur]

Buyurunuz...

Çok teşekkür ederim. Bir sorun daha olacaktı. Sayfa sayısını arttırınca kod kısmında hangi alanlara ekleme yapmam gerekir ?

 

[ÖmerBey]

sayfa = Array("AA", "BB", " CC")
Bu satıra işlem yaptırmak istediğiniz sayfaları formatı bozmadan ilave edebilirsiniz.
sayfa = Array("AA", "BB", " CC", "DD", "EE") gibi...

 

[abnur]

sayfa = Array("AA", "BB", " CC")
Bu satıra işlem yaptırmak istediğiniz sayfaları formatı bozmadan ilave edebilirsiniz.
sayfa = Array("AA", "BB", " CC", "DD", "EE") gibi...

Listelediği verilerin sayfalarınıda özet sayfası f sütununda yanlarına yazabilir mi ?

 

[abnur]

Arama listesinde olup sayfalarda olmayanlarda bu tip bir hata veriyor. Bu hata yerine "Sayfalarda bu tür bir veri yoktur" türünde bir uyarı verebilir miyiz ?

 

[ÖmerBey]

Kodu aşağıdaki şekilde güncelleyiniz.

Sub kod()
Dim say As Integer, a As Integer
Dim s1 As Worksheet, s2 As Worksheet
Dim trf As String, S As String, M As String, T As String

sayfa = Array("AA", "BB", " CC")

Set s1 = Sheets("ÖZET")
trf = s1.Range("A2").Value
If trf = "" Then Exit Sub
For Each syf In sayfa
    Set s2 = Sheets(syf)
    say = say + WorksheetFunction.CountIf(s2.Range("F:F"), trf)
Next
If say = 0 Then
    MsgBox trf & " için veri bulunamadı."
    Exit Sub
End If

ReDim dz(1 To say, 1 To 4)

For Each syf In sayfa
    Set s2 = Sheets(syf)
    For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
        If s2.Cells(a, "B") <> "" Then
            S = s2.Cells(a, "B").Value
            M = s2.Cells(a, "C").Value
            T = s2.Cells(a, "D").Value
        End If
        If s2.Cells(a, "F") = trf Then
            x = x + 1
            dz(x, 1) = S
            dz(x, 2) = M
            dz(x, 3) = T
            dz(x, 4) = s2.Name
        End If
    Next
Next
s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)(2)).ClearContents
s1.Range("B2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

 

[abnur]

Kodu aşağıdaki şekilde güncelleyiniz.

Sub kod()
Dim say As Integer, a As Integer
Dim s1 As Worksheet, s2 As Worksheet
Dim trf As String, S As String, M As String, T As String

sayfa = Array("AA", "BB", " CC")

Set s1 = Sheets("ÖZET")
trf = s1.Range("A2").Value
If trf = "" Then Exit Sub
For Each syf In sayfa
    Set s2 = Sheets(syf)
    say = say + WorksheetFunction.CountIf(s2.Range("F:F"), trf)
Next
If say = 0 Then
    MsgBox trf & " için veri bulunamadı."
    Exit Sub
End If

ReDim dz(1 To say, 1 To 4)

For Each syf In sayfa
    Set s2 = Sheets(syf)
    For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
        If s2.Cells(a, "B") <> "" Then
            S = s2.Cells(a, "B").Value
            M = s2.Cells(a, "C").Value
            T = s2.Cells(a, "D").Value
        End If
        If s2.Cells(a, "F") = trf Then
            x = x + 1
            dz(x, 1) = S
            dz(x, 2) = M
            dz(x, 3) = T
            dz(x, 4) = s2.Name
        End If
    Next
Next
s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)(2)).ClearContents
s1.Range("B2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Merhaba,

Sayfa isimleri geliyor ama sol tarafdaki sütunlar gelmiyor.

Yardımlarınız için çooooook teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Onlar bir önceki listelemeden kalma veriler. Silerken E sütunu atlandığı için orada kalmışlar, o kısmı düzenlememişim.
Aşağıdaki satırdaki "D" harfini "E" ile değiştirip deneyiniz.

s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)(2)).ClearContents