Liste Oluşturma

M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
Ekli Dosyamda açıklama yaptım.
Teşekkürler.
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,511
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Sayfalarda ki hangi sütunları ilgili sayfaya aktarmak istiyorsunuz?
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodları Sayfa1'in kod sayfasına (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırıp deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
    s1.Range("A4:V" & eski).ClearContents
    s1.Range("A4:V" & eski).Interior.Color = xlNone
    s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To Sheets.Count
    If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
        son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
        If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
           yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
           Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
          
           sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
           Set rs = con.Execute(sorgu)
           s1.Range("B" & yeni + 1).CopyFromRecordset rs
        End If
    End If
Next

enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
    For j = 4 To enson
        If s1.Cells(j, "B") = Target Then
            s1.Cells(j, "A") = a
            a = a + 1
        Else
            sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
        End If
    Next
End If
Columns("A:V").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation

End Sub
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi daha iyi oldu sanki:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
    s1.Range("A4:V" & eski).ClearContents
    s1.Range("A4:V" & eski).Interior.Color = xlNone
    s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To Sheets.Count
    If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
        son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
        If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
           yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
           Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
          
           sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
           Set rs = con.Execute(sorgu)
           s1.Range("B" & yeni + 1).CopyFromRecordset rs
        End If
    End If
    sonsut = s1.Cells(yeni, Columns.Count).End(xlToLeft).Column
    If WorksheetFunction.CountIf(Range(Cells(yeni, "A"), Cells(yeni, sonsut)), "TARIH") > 0 Then
        enson = s1.Cells(Rows.Count, "B").End(3).Row
        sut = WorksheetFunction.Match("TARIH", s1.Range(Cells(yeni, "A"), Cells(yeni, sonsut)), 0)
        Range(Cells(yeni, sut), Cells(enson, sut)).NumberFormat = "dd/mm/yyyy"
    End If
Next

enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
    For j = 4 To enson
        sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
        If s1.Cells(j, "B") = Target Then
            s1.Cells(j, "A") = a
            a = a + 1
        Else
            If j > 4 Then Cells(j, "A").ClearContents
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
        End If
    Next
End If
Range("B4:B" & enson).Delete shift:=xlToLeft
Range("A4:A" & enson).HorizontalAlignment = xlCenter
Columns("A:U").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation

End Sub
 
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
sonsut = s1.Cells(yeni, Columns.Count).End(xlToLeft).Column
burada 1004 hatası veriyor.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Dosyayı hata verdiği haliyle paylaşır mısınız?
 
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
Dosyayı hata verdiği haliyle paylaşır mısınız?
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Sanıyorum A1 hücresindeki Fide sayfa adının sonundaki boşluktan kaynaklanıyor. Kodun düzgün çalışması için 1. satıra yazdığınız sayfa isimlerinin gerçek sayfa isimleriyle birebir aynı olması gerekir. Kodu aşağıdakiyle değiştirirseniz hatalı sayfa adlarını dikkate almaz ve o hücreyi kırmızıya boyar:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
    s1.Range("A4:V" & eski).ClearContents
    s1.Range("A4:V" & eski).Interior.Color = xlNone
    s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, "A"), Cells(1, sonsut)).Interior.Color = xlNone
For i = 1 To Sheets.Count
    If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
        son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
        If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
            yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
            Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
          
            sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
            Set rs = con.Execute(sorgu)
            s1.Range("B" & yeni + 1).CopyFromRecordset rs
            sonsut = s1.Cells(yeni, Columns.Count).End(xlToLeft).Column
            If WorksheetFunction.CountIf(Range(Cells(yeni, "A"), Cells(yeni, sonsut)), "TARIH") > 0 Then
                enson = s1.Cells(Rows.Count, "B").End(3).Row
                sut = WorksheetFunction.Match("TARIH", s1.Range(Cells(yeni, "A"), Cells(yeni, sonsut)), 0)
                Range(Cells(yeni, sut), Cells(enson, sut)).NumberFormat = "dd/mm/yyyy"
            End If
        End If
    End If
Next

enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
    For j = 4 To enson
        sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
        If s1.Cells(j, "B") = Target Then
            s1.Cells(j, "A") = a
            a = a + 1
        Else
            If j > 4 Then Cells(j, "A").ClearContents
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
            s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
        End If
    Next
End If
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For m = 1 To sonsut
    sayfa = "Yok"
    For n = 1 To Sheets.Count
        If Sheets(n).Name = Cells(1, m) Then
            sayfa = "Var"
        End If
    Next
    If sayfa = "Yok" Then
        Cells(1, m).Interior.Color = vbRed
    End If
Next
Range("B4:B" & enson).Delete shift:=xlToLeft
Range("A4:A" & enson).HorizontalAlignment = xlCenter
Columns("A:U").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation

End Sub
 
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
Yusuf Bey Hemşehrim Çok Teşekkür ederim.Salihliden Selam.
Sizi Bu konuda tekrar rahatsız edeceğim dosyamı tam hazırlayınca.
Tablo başlıklarını almadan listeleme yapamazmıyız.
ben sayfa1 de tablo oluşturup başlıklarını koyacağım.
birde fide sayfasında 1 den fazla olan kişilerde hiç bir bilgi getirmiyor.
mesela refik doğan çağırınca bilgi gelmiyor.
 
Son düzenleme:
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aleykümselam. Salihli'ye benden de selam ama pek hemşeri sayılmayız, Malatyalıyım, iş gereği çok uzun zamandır Kulalı oldum ama :)

Fide sayfasındaki hatanın sebebini bir önceki mesajımda açıklamıştım, A1 hücresinde Fide ifadesinin sonunda bir boşluk bırakmışsınız, o boşluğu silerseniz düzgün çalıştığını görürsünüz.

Başlıkları da almamın sebebi sayfalarınızdaki sütunların birebir aynı olmaması. Sanıyorum Ekici sayfasından veri almak istemiyorsunuz ama Fide sayfasında V sütununa kadar veri varken diğer sayfalarda P sütununa kadar veriler var. Eğer başlıkları almazsam sayfalardan alınan verilerin ne olduğunu belirleyemezsiniz.

Başlıklarla ilgili başka bir düşünceniz varsa dosyanızı ona göre güncelleyin, kodları düzeltmeye çalışayım.
 
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
Açıklamayı Dosya içersinde yapmaya çalıştım.
özettablo,Fonksiyon,Makro olabilir.
Teşekkürler.
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodları deneyiniz:

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:D1]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 2 Then
    s1.Range("A3:N" & eski).ClearContents
End If

If Target = "" Then Exit Sub
kisi = [B1].Value
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

Application.EnableEvents = False
Application.ScreenUpdating = False
    sat = 3
    For i = 1 To Sheets.Count
        If Sheets(i).Name = "Yazlık" Or Sheets(i).Name = "Kışlık" Or Sheets(i).Name = "Tohum" Or _
                            Sheets(i).Name = "Gübre" Or Sheets(i).Name = "Sulama" Then
            son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
            If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), kisi) > 0 Then
                say = WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), kisi)
                sorgu = "select F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18 from[" & Sheets(i).Name & "$A2:R" & son & "] where F2='" & kisi & "'"
                Set rs = con.Execute(sorgu)
                s1.Range("B" & sat).CopyFromRecordset rs
                sat = sat + say
            End If
        End If
    Next
    For j = 3 To sat - 1
        s1.Cells(j, "A") = j - 2
    Next
    s1.Columns("A:N").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation

End Sub
 
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Altın Üyelik Bitiş Tarihi
13.01.2022
Teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst