macro düzenleme

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
527
Excel Vers. ve Dili
Office 2010 / 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.
 

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
527
Excel Vers. ve Dili
Office 2010 / Türkçe
konu günceldir arkadaşlar,
yok mu yardım edecek biri
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
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
 

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
527
Excel Vers. ve Dili
Office 2010 / Türkçe
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
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
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
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
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
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)
 

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
527
Excel Vers. ve Dili
Office 2010 / Türkçe
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)

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

Ekli dosyalar

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
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
 

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
527
Excel Vers. ve Dili
Office 2010 / Türkçe
Çok teşekkür ederim istediğim tam olarak buydu
 
Üst