Sorgula Yazdır.

[Mikdad]

Selamun aleykum dostlarım.
A,B,C,D,E,F,G,H Sutunlarından oluşan bir excel sayfam var.
G sutununda Personel isimleri var.
İ.M.
İ.Ş.
İ.Ç.
İ.Ç.
İ.M.
N.D
İ.Ç.
A.Y.
V.Ç.

vb şeklinde(bunları örnek verdim personel sayısı çok daha fazla

yapmak istediğim şey ise sırala ve filtre uygulama kısmında flitre uygulayıp teker teker personelleri seçip yazdır demek yerine
bir Filtrele ve Yazdır buttonuna tıkladığımda teker teker sorgulayıp her sorguladığını yazdırması .
Yani G Sutunundaki ilk personel A.Y personelini filtreliyecek dökecek, sonra İ.Ç isimli personeli seçecek dökecek, sonra diğer personele geçecek.
bu konuda yardımcı olur musunuz.

 

[Emir Hüseyin Çoban]

.

Sub kod()

sonsat = Cells(Rows.Count, "G").End(3).Row
For i = 8 To sonsat

If WorksheetFunction.CountIf(Range("G8:G" & i), Cells(i, "G")) = 1 Then
    ActiveSheet.Range("$B$7:$H$" & sonsat).AutoFilter Field:=6, Criteria1:=Cells(i, "G")
    ActiveSheet.PrintOut
End If
Next i

End Sub

.

 

[Mikdad]

.

Sub kod()

sonsat = Cells(Rows.Count, "G").End(3).Row
For i = 8 To sonsat

If WorksheetFunction.CountIf(Range("G8:G" & i), Cells(i, "G")) = 1 Then
    ActiveSheet.Range("$B$7:$H$" & sonsat).AutoFilter Field:=6, Criteria1:=Cells(i, "G")
    ActiveSheet.PrintOut
End If
Next i

End Sub

.

Değerli Hocam Allah razı olsun. sadece bir sıkıntı var formullu olan boş satırları da yazdırıyor(b den başlayıp H sutununa kadar tüm satırlarda formul var) boşları yazdırmamasını nasıl sağlarız . yani A sutununa baksın eğer boş ise yazmasın.

 

[Emir Hüseyin Çoban]

.

Örnek dosyada bu işlem yok ama şu kodları deneyin.

Sub kod()

sonsat = Cells(Rows.Count, "G").End(3).Row
For i = 8 To sonsat

If WorksheetFunction.CountIf(Range("G8:G" & i), Cells(i, "G")) = 1 And Cells(i, "A") <> "" Then
    ActiveSheet.Range("$B$7:$H$" & sonsat).AutoFilter Field:=6, Criteria1:=Cells(i, "G")
    ActiveSheet.PrintOut
End If
Next i

End Sub

.

 

[Mikdad]

.

Örnek dosyada bu işlem yok ama şu kodları deneyin.

Sub kod()

sonsat = Cells(Rows.Count, "G").End(3).Row
For i = 8 To sonsat

If WorksheetFunction.CountIf(Range("G8:G" & i), Cells(i, "G")) = 1 And Cells(i, "A") <> "" Then
    ActiveSheet.Range("$B$7:$H$" & sonsat).AutoFilter Field:=6, Criteria1:=Cells(i, "G")
    ActiveSheet.PrintOut
End If
Next i

End Sub

.

Hocam Allah Razı Olsun tam istediğim gibi oldu hakkınızı helal edin. tekrar teşekkür ederim. .

 

[Mikdad]

selamun aleykum hocam, verdiğiniz bu kod ile şuan normal şartlarda sorgulamıp yazdırıyor. ama manuel flitreleme yaptığımda mesala bir personelin 30 satır kaydı var ama bu kod ile sorguladığımda 25 tane olarak sorguluyor.bunu bir türlü çözemedim acama sıkıntı nedir?

 

[Emir Hüseyin Çoban]

.

Bu hatanın olduğu dosyadan örnek paylaşırsanız inceleyebilirim.

.

 

[Mikdad]

Selamun Aleykum hocalarım, g sutununu filtreleyip her flitrelediğimi yazdırıyorum. buraya kadar sorun yok. ama bu kod ile bunu yaptığım zaman
bazı flitrelenen kayıtlar eksik geliyor. yani manuel olarak yaptığımda 25 tane gelirken, bu kod ile sorguladığımda 23 tane geliyor. ve her seferinde farklı bir kayıtta bunu veriyor. acaba kod ile ilgili bir sıkıntı mı var?

Sub FiltreleYazdir2020()
' FİLTRELE VE YAZDIR BUTTONU
sonsat = Cells(Rows.Count, "G").End(3).Row
For i = 8 To sonsat

If WorksheetFunction.CountIf(Range("G8:G" & i), Cells(i, "G")) = 1 And Cells(i, "A") <> "" Then
    ActiveSheet.Range("$B$7:$H$" & sonsat).AutoFilter Field:=7, Criteria1:=Cells(i, "G")
    'ActiveSheet.PrintOut
      ActiveSheet.PrintPreview
End If
Next i
End Sub

 

[bmutlu966]

Bir de aşağıdaki kodları dener misiniz. BM kolonu yardımcı kolon olarak kullanılıyor.

Sub FiltreleYazdir2020()

Application.ScreenUpdating = False
Columns("BM:BM").ClearContents
    Range("G8:G65000").Select
    Selection.Copy
    Range("BM1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("$BM$1:$BM$65000").RemoveDuplicates Columns:=1, Header:=xlNo

sonsat = Cells(Rows.Count, "BM").End(3).Row

For i = 1 To sonsat

    ActiveSheet.Range("$B$7:$H$65000).AutoFilter Field:=6, Criteria1:=Cells(i, "BM")
    'ActiveSheet.PrintOut
    ActiveSheet.PrintPreview

Next i
ActiveSheet.Range("$B$7:$H$65000).AutoFilter

Application.ScreenUpdating = True
Range("A1").Select

End Sub