• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı sayfadaki verileri tek sayfada listelemek

  • Konbuyu başlatan Konbuyu başlatan abnur
  • Başlangıç tarihi Başlangıç tarihi
A

abnur

Altın Üye
Katılım
5 Eylül 2022
Mesajlar
78
Excel Vers. ve Dili
2021 Türkçe
Merhaba,

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

Ekli dosyalar

Merhaba,
Örnek dosyanız için deneyiniz...
PHP: 
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
 
ÖmerBey' Alıntı:
Merhaba,
Örnek dosyanız için deneyiniz...
PHP: 
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
Genişletmek için tıkla ...


Bunu excel ekledim fakat bir sonuç alamadım. Ekli halde iletmeniz mümkün müdür ?
 
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...
 
ÖmerBey' Alıntı:
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...
Genişletmek için tıkla ...

Listelediği verilerin sayfalarınıda özet sayfası f sütununda yanlarına yazabilir mi ?
 
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 ?

252460
 
Kodu aşağıdaki şekilde güncelleyiniz.
Rich (BB code): 
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
 
ÖmerBey' Alıntı:
Kodu aşağıdaki şekilde güncelleyiniz.
Rich (BB code): 
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
Genişletmek için tıkla ...
Merhaba,

Sayfa isimleri geliyor ama sol tarafdaki sütunlar gelmiyor.

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

Ekli dosyalar

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.
Rich (BB code): 
s1.Range(s1.Range("B2"), s1.Cells(Rows.Count, "D").End(3)(2)).ClearContents
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst