• DİKKAT

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

macro düzenleme

catalinastrap

catalinastrap

Özgür
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
644
Excel Vers. ve Dili
Microsoft® Excel® Microsoft 365 için MSO /64 bit /Türkçe
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:="1 OF 1"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:="2 OF 2"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False


ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:="3 OF 3"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False


ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:="3 OF 3"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False

ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:="4 OF 4"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False



kodu 3 OF 3 yada 4 OF 4 son kriter ise macro dursun şeklinde nasıl derleyebiliriz

yani bakılan filitfede yazılan kurallar misal 100 OF 100 ama data 60 OF 60 ta bitiyor ise macronun kalan kısmı çalışmasın işlem sonuna gitsin.
 
konu günceldir arkadaşlar,
yok mu yardım edecek biri
 
Merhaba
Aşağıdaki gibi; döngü ile işinize yararmı?

Kod: 
For x = 1 To 100
ActiveSheet.Range("$A$17:$I$672").AutoFilter
Set ara = ActiveSheet.Range("$A$17:$I$672").Find(x & " OF " & x, , , xlWhole)
If Not ara Is Nothing Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=x & " OF " & x
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
 
PLİNT' Alıntı:
Merhaba
Aşağıdaki gibi; döngü ile işinize yararmı?

Kod: 
For x = 1 To 100
ActiveSheet.Range("$A$17:$I$672").AutoFilter
Set ara = ActiveSheet.Range("$A$17:$I$672").Find(x & " OF " & x, , , xlWhole)
If Not ara Is Nothing Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=x & " OF " & x
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
Genişletmek için tıkla ...

Merhabalar,
kod çalışmadı bir hatamı yapıyorum acaba

Sub Yazdır()
For x = 1 To 100
ActiveSheet.Range("$A$17:$I$672").AutoFilter
Set ara = ActiveSheet.Range("$A$17:$I$672").Find(x & " OF " & x, , , xlWhole)
If Not ara Is Nothing Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=x & " OF " & x
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next

End Sub
 
Merhaba
Kodları ekdeki dosyada uygulayıp (Yazdırılacak sayfanın aktif olduğu sırada,yazdırmayı) denedim sorun çıkmadı
https://www.dosyaupload.com/jsgK
Krtiterleri aşağıdaki gibi liste yapıp deneyebilirsiniz
Kod: 
Sub Yazdır_2()

krt = Array("1 OF 1", "2 OF 2", "3 OF 3")

For x = 0 To UBound(krt)
ActiveSheet.Range("$A$17:$I$672").AutoFilter
Set ara = ActiveSheet.Range("$A$17:$I$672").Find(krt(x), , , xlWhole)
If Not ara Is Nothing Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=krt(x)
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
ActiveSheet.Range("$A$17:$I$672").AutoFilter
End Sub

Not : Mesela "2 OF 2" bulunmadığı, 3. kritere atlaması istenirse "Exit For" satırı silinir
 
Aşağıdaki örnekte arama yerine "eğersay" ile deneme bulunuyor
https://www.dosyaupload.com/jsgV
Kod: 
Sub Yazdır()
For x = 1 To 100
ActiveSheet.Range("$A$17:$I$672").AutoFilter
If WorksheetFunction.CountIf(ActiveSheet.Range("$A$17:$A$672"), x & " OF " & x) > 0 Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=x & " OF " & x
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
ActiveSheet.Range("$A$17:$I$672").AutoFilter
End Sub
'----------------------------------------


Sub Yazdır_2()

krt = Array("1 OF 1", "2 OF 2", "3 OF 3")

For x = 0 To UBound(krt)
ActiveSheet.Range("$A$17:$I$672").AutoFilter
If WorksheetFunction.CountIf(Range("$A$17:$A$672"), UBound(krt)) > 0 Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=krt(x)
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
ActiveSheet.Range("$A$17:$I$672").AutoFilter
End Sub

Bir önceki kodlarda arama sadece "A" sütunu için yeterli olacaktı,düzeltirsiniz
Set ara = ActiveSheet.Range("$A$17:$A$672").Find(krt(x), , , xlWhole)
 
PLİNT' Alıntı:
Aşağıdaki örnekte arama yerine "eğersay" ile deneme bulunuyor
https://www.dosyaupload.com/jsgV
Kod: 
Sub Yazdır()
For x = 1 To 100
ActiveSheet.Range("$A$17:$I$672").AutoFilter
If WorksheetFunction.CountIf(ActiveSheet.Range("$A$17:$A$672"), x & " OF " & x) > 0 Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=x & " OF " & x
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
ActiveSheet.Range("$A$17:$I$672").AutoFilter
End Sub
'----------------------------------------


Sub Yazdır_2()

krt = Array("1 OF 1", "2 OF 2", "3 OF 3")

For x = 0 To UBound(krt)
ActiveSheet.Range("$A$17:$I$672").AutoFilter
If WorksheetFunction.CountIf(Range("$A$17:$A$672"), UBound(krt)) > 0 Then
ActiveSheet.Range("$A$17:$I$672").AutoFilter Field:=1, Criteria1:=krt(x)
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Else
Exit For
End If
Next
ActiveSheet.Range("$A$17:$I$672").AutoFilter
End Sub

Bir önceki kodlarda arama sadece "A" sütunu için yeterli olacaktı,düzeltirsiniz
Set ara = ActiveSheet.Range("$A$17:$A$672").Find(krt(x), , , xlWhole)
Genişletmek için tıkla ...


Kodu uyguladım ama yine sonuç alamadım,
dosyayı yüklüyorum bakabilirmisiniz
 

Ekli dosyalar

Merhaba
Anladığımdan, farklıymış yukarıdaki gibi zaten toplam satırı görünmeyecekti ek dosyadaki gibi bir çözüm işinize yarayablir.
"TOTAL" satırı ve örnek dosyanızdaki gibi; kriterler içerisinde "OF" kelimesi olmalı
https://www.dosyaupload.com/b428
Kod: 
Sub Yazdır()

ActiveSheet.AutoFilterMode = False
Set c = ActiveSheet.Range("$A$18:$B$10000").Find("TOTAL", , xlValues, xlPart, xlByRows, xlPrevious)
If Not c Is Nothing Then
s = ActiveSheet.Range("$A$18:$B$" & c.Row - 1).Find("*", , , , xlByRows, xlPrevious).Row
Else
MsgBox "TOTAL Satırı bulunamadı"
Exit Sub
End If

For Each x In ActiveSheet.Range("$A$18:$A$" & s - 1).SpecialCells(xlCellTypeConstants, 3).Cells
If WorksheetFunction.CountIf(ActiveSheet.Range("$A$15:$A$" & x.Row), x.Value) = 1 And x.Value <> "" _
And InStr(1, x.Value, "OF", vbTextCompare) <> 0 Then
ActiveSheet.Range("$A$17:$I$" & s - 1).AutoFilter Field:=1, Criteria1:=x.Value
If (c.Row - 1) - (s + 1) > 3 Then ActiveSheet.Range("$A$" & s + 2 & ":$A$" & c.Row - 1).EntireRow.Hidden = True
ActiveSheet.PageSetup.PrintArea = ActiveSheet.Range("$A$15:$I$" & c.Row + 4).Address
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
ActiveSheet.AutoFilterMode = False
End If
Next
ActiveSheet.Range("A15:A1000").EntireRow.Hidden = False
End Sub
 
Çok teşekkür ederim istediğim tam olarak buydu
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst