Şartlı yazdırma isteği

[drummers]

ekteki dosyada yanlızca "sarı" ile boyanmış hücrelerin içeriğinin yazıcıdan çıkmasını nasıl sağlıyabilirim

 

[Orion1]

Bir bakın bakaılım böylemi istediniz.

Sub yazdir()
Dim alan As Range, hcr As Range
Set alan = Range("A1:AN27")
For Each hcr In alan
    If hcr.Interior.Color <> vbYellow Then
    hcr.Font.Color = vbWhite
    End If
Next
ActiveSheet.ScrollArea = "A9:AN27"
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.ScrollArea = ""
For Each hcr In alan
    If hcr.Interior.Color <> vbYellow Then
        hcr.Font.Color = vbBlack
    End If
Next
MsgBox "Yazdırma işlemi başarı ile bitti." & vbLf & vbLf _
& "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
      
End Sub

 

[drummers]

evet teşekkürler biraz değişiklikle işi yaradı .. sağolun

 

[drummers]

yazdırma alanı

öncelikle gereksiz db şişkinliği ve kirliliği için özür dilerim... dün konuyu açmama rağmen derdime derman bulamadım...

ekli dosyada da görüleceği üzere istediğim şudur

- sayfaya "yazdır" isimli bir tuş koyacağız

- yazdırılacak alan sadece ("Adı Soyadı/Ünvanı + adresi+ vergi dairesi vs..vs..vs.. ") beyaz zemin rengi ile kalmış alanlar

- diğer alanların yazıcıdan yazdırılmasını istemiyorum sadece zemin rengi beyaz olan alanlar


teşekkürler konuyu 2 sefer açtığım için kusura bakmayın

 

[drummers]

yardım rica edebilirmiyim

 

[halit3]

yardım rica edebilirmiyim

Sub yazdır1()
'Cells.Interior.ColorIndex = xlNone
For i = 1 To 28
For j = 1 To 40
If Worksheets(ActiveSheet.Name).Cells(i, j).Interior.ColorIndex = 15 Then
Worksheets(ActiveSheet.Name).Cells(i, j).Interior.ColorIndex = 2
Worksheets(ActiveSheet.Name).Cells(i, j).Font.ColorIndex = 2
End If
Next j
Next i
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.PageSetup.PrintArea = "$A$1:$AN$28"
For i = 1 To 28
For j = 1 To 40
If Worksheets(ActiveSheet.Name).Cells(i, j).Interior.ColorIndex = 2 Then
Worksheets(ActiveSheet.Name).Cells(i, j).Interior.ColorIndex = 15
Worksheets(ActiveSheet.Name).Cells(i, j).Font.ColorIndex = 1
End If
Next j
Next i
MsgBox "işlem tamam"
End Sub

Sub yazdır()
Dim rng As Range
'alan.Interior.ColorIndex = xlNone
For Each rng In Range("A1:AN28")
If rng.Interior.ColorIndex = 15 Then
rng.Interior.ColorIndex = 2
rng.Font.ColorIndex = 2
End If
Next rng
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.PageSetup.PrintArea = "$A$1:$AN$28"
For Each rng In Range("A1:AN28")
If rng.Interior.ColorIndex = 2 Then
rng.Interior.ColorIndex = 15
rng.Font.ColorIndex = 1
End If
Next rng
MsgBox "işlem tamam"
End Sub

ekli dosyaya bir bak

 

[drummers]

elerinize sağlık