Çözüldü Excel de Filitre Sırasına göre Rapor hazırlama

[veysikulte1]

Merhabalar, Ekteki dosyada liste kısmında müşteri listesi var karşılarında aldığı kg sayısı var 1 kg filitreleyip Rapor sayfasına yapıştırıp 2 kg kopyalayıp rapor kısmına 1 kg lığın altına yapıştırıp ve bu döngü listedeki filitre sayısına göre yapılması ve bunu sürekli manuel yapıyoruz bunun çıktısını alıyoruz. Arkadaşlar çıktıya göre paketlemelerini hazırlıyolar. Rapor sayfasında örnek olarak 1 den 5 e kadar eklemişim. Bunun daha kolay yolu varmı günlük listemi hazırladığımda bunu otomatik rapor kısmına aktarıp yazdırmamı sağlaması için yardımlarınızı rica ediyorum.

 

[walabi]

C sütunundaki KG tipleriniz sabit mi değişken mi, bunlar KG lık paket ya da torbasal ürünler gibi . Sanırım formülle olabilir. En temizi ise makrosal çözüm.

 

[veysikulte1]

C sütunundaki KG tipleriniz sabit mi değişken mi, bunlar KG lık paket ya da torbasal ürünler gibi . Sanırım formülle olabilir. En temizi ise makrosal çözüm.

c sütunu günlük değişiyor

 

[veysikulte1]

Yardımcı olabilir misiniz lütfen

 

[necati]

Merhaba,
Ben ikinci sayfayı yani "Rapor" sayfasını kullanmaya gerek olmayan bir yazdırma kodu ayarladım.
Sadece "liste" sayfasında iken makroyu çalıştırıyoruz, her paket türünü ayrı ayrı yazıcıya gönderiyor.

Option Explicit
Sub Filtrele_Yazdir()
Dim s1 As Worksheet
Dim ss As Long, sonsatK As Integer, fl As Integer
Dim rgdata As Range

Application.ScreenUpdating = False

Set s1 = ActiveSheet

With s1
    ss = .Range("C5").CurrentRegion.Rows.Count
    Set rgdata = .Range("B5").CurrentRegion
   
    .Range("C5:C" & ss).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("K1"), Unique:=True
    .Range("K1:K" & Cells(Rows.Count, 1).End(3).Row).Sort Range("K1"), xlAscending, Range("K1"), , , , , xlYes
    sonsatK = .Range("K1").End(xlDown).Row

    If .AutoFilterMode = False Then .Range("B5:G5").AutoFilter

    For fl = 2 To sonsatK
        rgdata.AutoFilter Field:=2, Criteria1:=.Range("K" & fl).Text, Operator:=xlAnd
        .PageSetup.PrintArea = .Range("A1:G" & ss).Address
        .PrintOut '.PrintOut 'PrintPreview
        .ShowAllData
    Next fl

    .Range("K1:K" & sonsatK).Clear
End With

Application.ScreenUpdating = True
MsgBox "Paketler ayrı ayrı yazdırıldı", vbInformation

End Sub

 

[veysikulte1]

Merhaba,
Ben ikinci sayfayı yani "Rapor" sayfasını kullanmaya gerek olmayan bir yazdırma kodu ayarladım.
Sadece "liste" sayfasında iken makroyu çalıştırıyoruz, her paket türünü ayrı ayrı yazıcıya gönderiyor.

Option Explicit
Sub Filtrele_Yazdir()
Dim s1 As Worksheet
Dim ss As Long, sonsatK As Integer, fl As Integer
Dim rgdata As Range

Application.ScreenUpdating = False

Set s1 = ActiveSheet

With s1
    ss = .Range("C5").CurrentRegion.Rows.Count
    Set rgdata = .Range("B5").CurrentRegion
  
    .Range("C5:C" & ss).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("K1"), Unique:=True
    .Range("K1:K" & Cells(Rows.Count, 1).End(3).Row).Sort Range("K1"), xlAscending, Range("K1"), , , , , xlYes
    sonsatK = .Range("K1").End(xlDown).Row

    If .AutoFilterMode = False Then .Range("B5:G5").AutoFilter

    For fl = 2 To sonsatK
        rgdata.AutoFilter Field:=2, Criteria1:=.Range("K" & fl).Text, Operator:=xlAnd
        .PageSetup.PrintArea = .Range("A1:G" & ss).Address
        .PrintOut '.PrintOut 'PrintPreview
        .ShowAllData
    Next fl

    .Range("K1:K" & sonsatK).Clear
End With

Application.ScreenUpdating = True
MsgBox "Paketler ayrı ayrı yazdırıldı", vbInformation

End Sub

hocam öncelikle çok teşekkür ederim çok güzel olmuş bunları alt altta bir veya 2 sayfa olacak şekilde örneğin pdf olarak birleştiğinde yazdırdığında 10 sayfa yazmak yerine hepsi 2 veya 3 sayfa olur o şekilde olabilir mi acaba

 

[necati]

Alt altta kopyala/yapıştırmak için:

Sub Filtrele_Yazdir()
Dim s1 As Worksheet, s2 As Worksheet
Dim ss1 As Long, ss2 As Long, sonsatK As Integer, fl As Integer
Dim rgdata As Range, m As Long, n As Integer

Application.ScreenUpdating = False

Set s1 = ActiveSheet
Set s2 = Sheets("Rapor")
s2.UsedRange.Clear

With s1
    ss1 = .Range("C5").CurrentRegion.Rows.Count
    Set rgdata = .Range("B5").CurrentRegion
    s1.Range("B5").AutoFilter
    
    .Range("C5:C" & ss1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("K1"), Unique:=True
    .Range("K1:K" & Cells(Rows.Count, 1).End(3).Row).Sort Range("K1"), xlAscending, Range("K1"), , , , , xlYes
    sonsatK = .Range("K1").End(xlDown).Row

    If .AutoFilterMode = False Then .Range("B5:G5").AutoFilter

    For fl = 2 To sonsatK
        rgdata.AutoFilter Field:=2, Criteria1:=.Range("K" & fl).Text, Operator:=xlAnd
        rgdata.Copy s2.Range("A" & 1 + ss2 + n)
        ss2 = s2.Cells.Find("*", , , , xlByRows, xlPrevious).Row
        s2.Range("A" & m + 1 & ":G" & ss2 + 1).BorderAround ColorIndex:=1, Weight:=xlMedium
        m = ss2 + 1: n = 2
        .ShowAllData
    Next fl

    .Range("K1:K" & sonsatK).Clear
    s2.Range("A2:A" & ss2).Value = vbNullString
    s2.Range("A:G").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True
s2.PrintOut '.PrintOut 'PrintPreview

MsgBox "Rapor yazdırıldı", vbInformation

End Sub

 

[veysikulte1]

Alt altta kopyala/yapıştırmak için:

Sub Filtrele_Yazdir()
Dim s1 As Worksheet, s2 As Worksheet
Dim ss1 As Long, ss2 As Long, sonsatK As Integer, fl As Integer
Dim rgdata As Range, m As Long, n As Integer

Application.ScreenUpdating = False

Set s1 = ActiveSheet
Set s2 = Sheets("Rapor")
s2.UsedRange.Clear

With s1
    ss1 = .Range("C5").CurrentRegion.Rows.Count
    Set rgdata = .Range("B5").CurrentRegion
    s1.Range("B5").AutoFilter
   
    .Range("C5:C" & ss1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("K1"), Unique:=True
    .Range("K1:K" & Cells(Rows.Count, 1).End(3).Row).Sort Range("K1"), xlAscending, Range("K1"), , , , , xlYes
    sonsatK = .Range("K1").End(xlDown).Row

    If .AutoFilterMode = False Then .Range("B5:G5").AutoFilter

    For fl = 2 To sonsatK
        rgdata.AutoFilter Field:=2, Criteria1:=.Range("K" & fl).Text, Operator:=xlAnd
        rgdata.Copy s2.Range("A" & 1 + ss2 + n)
        ss2 = s2.Cells.Find("*", , , , xlByRows, xlPrevious).Row
        s2.Range("A" & m + 1 & ":G" & ss2 + 1).BorderAround ColorIndex:=1, Weight:=xlMedium
        m = ss2 + 1: n = 2
        .ShowAllData
    Next fl

    .Range("K1:K" & sonsatK).Clear
    s2.Range("A2:A" & ss2).Value = vbNullString
    s2.Range("A:G").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True
s2.PrintOut '.PrintOut 'PrintPreview

MsgBox "Rapor yazdırıldı", vbInformation

End Sub

Çok teşekkür ederim hocam çok güzel oldu. Ama sayfaya sığmıyor 20 sayfaya dönüşüyor yatay olarak yazdırılabilir alana dönüşmesini sağlamamız mümkün mü?

 

[necati]

s2.PrintPreview '.PrintOut 'PrintPreview yazan satırı aşağıdaki gibi ayarlayınız.

s2.PageSetup.Orientation = xlLandscape
s2.PrintOut

 

[veysikulte1]

s2.PrintPreview '.PrintOut 'PrintPreview yazan satırı aşağıdaki gibi ayarlayınız.

s2.PageSetup.Orientation = xlLandscape
s2.PrintOut

Teşekkür ederim