filtreden rapor oluşturmak

[muhsar]

merhaba;ekte ki belgemde sayfa 1 de hastalarımıza randevu veriyoruz.FİLTRE isimli sayfada sayfa 1 in C sütunundaki randevu tarihine göre A2 hücresine yazılan tarihi süzüp getiriyoruz.ve o günün randevularını toplu olarak görüyoruz.EKİP isimli sayfada ;FİLTRE sayfasının j sütununda yazan ekip isimlerine göre süzme yapıyoruz.

benim yapmak istediğim ve yardımınızı rica ettiğim konu;rapor isimli sayfaya makro ile rapor oluştur dediğimde FİLTRE isimli sayfada listelenmiş olan günü randevularını
Ekip 1 den başlayıp listelemek.yani: rapor oluştur makrosunu çalıştırdığımda ilk olarak EKİP 1 randevuları gelecek devamında boşluk bırakıp ekip 2;ekip 3;ekip 4;ekip 5;
ekip 6 ;nakil şeklinde FİLTRE sayfasının J sütunundaki ekiplere göre toplu liste almak istiyorum.Ekip isimli sayfada tek tek yaptığım işlemi rapor sayfasında toplu olarak yapmak.

şimdiden teşekkür ediyorum.(filtfe sayfasında ki kodlar sn.ziynettin hocama aittir.)

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub rapor()
Set s1 = Sheets("FİLTRE")
Set s2 = Sheets("RAPOR")
eski = s2.Cells(Rows.Count, "A").End(3).Row
sonfiltre = s1.Cells(Rows.Count, "A").End(3).Row
s2.Range("A1:K" & eski).ClearContents
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"""

For i = 1 To 6
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11 " & _
      "from[FİLTRE$A4:K" & sonfiltre & "] where F10='" & "EKİP " & i & "'"
    
    Set rs = con.Execute(sorgu)
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 2
    If s2.[A1] = "" Then yeni = 1
    s2.Cells(yeni, "A").CopyFromRecordset rs
Next
sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11 " & _
  "from[FİLTRE$A4:K" & sonfiltre & "] where F10='" & "NAKİL" & "'"

Set rs = con.Execute(sorgu)
yeni = s2.Cells(Rows.Count, "A").End(3).Row + 2
If s2.[A1] = "" Then yeni = 1
s2.Cells(yeni, "A").CopyFromRecordset rs
s2.Columns("A:K").EntireColumn.AutoFit
s2.Activate
MsgBox "İşlem tamamlandı"

End Sub

 

[muhsar]

Aşağıdaki makroyu deneyiniz:

Sub rapor()
Set s1 = Sheets("FİLTRE")
Set s2 = Sheets("RAPOR")
eski = s2.Cells(Rows.Count, "A").End(3).Row
sonfiltre = s1.Cells(Rows.Count, "A").End(3).Row
s2.Range("A1:K" & eski).ClearContents
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"""

For i = 1 To 6
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11 " & _
      "from[FİLTRE$A4:K" & sonfiltre & "] where F10='" & "EKİP " & i & "'"
   
    Set rs = con.Execute(sorgu)
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 2
    If s2.[A1] = "" Then yeni = 1
    s2.Cells(yeni, "A").CopyFromRecordset rs
Next
sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11 " & _
  "from[FİLTRE$A4:K" & sonfiltre & "] where F10='" & "NAKİL" & "'"

Set rs = con.Execute(sorgu)
yeni = s2.Cells(Rows.Count, "A").End(3).Row + 2
If s2.[A1] = "" Then yeni = 1
s2.Cells(yeni, "A").CopyFromRecordset rs
s2.Columns("A:K").EntireColumn.AutoFit
s2.Activate
MsgBox "İşlem tamamlandı"

End Sub

çok teşekkür ederim elinize sağlık