YAZDIRMA MAKROSU

[excelience]

Merhaba üstatlar a3 ile g102 arasında dolu olan satırları makro ile nasıl yazdırabilirim şimdiden teşekkür ederim

 

[volki_112]

@excelience istediğini kod. Yapay zeka yazdı.

Sub YazdirDoluSatirlar()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim printRange As Range
    Dim satir As Long
    
    ' Aktif sayfayı al
    Set ws = ActiveSheet
    
    ' A3 ile G102 arasındaki son satırı belirle (veri olduğu son satır)
    lastRow = 102
    
    ' İlk başta boş olan printRange'i temizle
    Set printRange = Nothing
    
    ' A3-G102 arasındaki satırları kontrol et
    For satir = 3 To lastRow
        ' Eğer A, B, C, D, E, F veya G sütunlarından herhangi bir hücre doluysa, bu satırı ekle
        If Application.CountA(ws.Range("A" & satir & ":G" & satir)) > 0 Then
            ' Eğer printRange boşsa, ilk satırı ata
            If printRange Is Nothing Then
                Set printRange = ws.Rows(satir)
            Else
                ' Aksi takdirde, bu satırı mevcut printRange'e ekle
                Set printRange = Union(printRange, ws.Rows(satir))
            End If
        End If
    Next satir
    
    ' Eğer dolu satırlar varsa, yazdır
    If Not printRange Is Nothing Then
        printRange.PrintOut
    End If
End Sub

 

[Muzaffer Ali]

Merhaba.
Alternatif.

Sub Yazdır()
    Range("A3:G" & Cells(103, "A").End(xlUp).Row).PrintOut
End Sub

 

[excelience]

@excelience istediğini kod. Yapay zeka yazdı.

Sub YazdirDoluSatirlar()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim printRange As Range
    Dim satir As Long
   
    ' Aktif sayfayı al
    Set ws = ActiveSheet
   
    ' A3 ile G102 arasındaki son satırı belirle (veri olduğu son satır)
    lastRow = 102
   
    ' İlk başta boş olan printRange'i temizle
    Set printRange = Nothing
   
    ' A3-G102 arasındaki satırları kontrol et
    For satir = 3 To lastRow
        ' Eğer A, B, C, D, E, F veya G sütunlarından herhangi bir hücre doluysa, bu satırı ekle
        If Application.CountA(ws.Range("A" & satir & ":G" & satir)) > 0 Then
            ' Eğer printRange boşsa, ilk satırı ata
            If printRange Is Nothing Then
                Set printRange = ws.Rows(satir)
            Else
                ' Aksi takdirde, bu satırı mevcut printRange'e ekle
                Set printRange = Union(printRange, ws.Rows(satir))
            End If
        End If
    Next satir
   
    ' Eğer dolu satırlar varsa, yazdır
    If Not printRange Is Nothing Then
        printRange.PrintOut
    End If
End Sub

teşekkürler üstat

 

[excelience]

Merhaba.
Alternatif.

Sub Yazdır()
    Range("A3:G" & Cells(103, "A").End(xlUp).Row).PrintOut
End Sub

teşekkürler üstat

 

[volki_112]

Merhaba.
Alternatif.

Sub Yazdır()
    Range("A3:G" & Cells(103, "A").End(xlUp).Row).PrintOut
End Sub

Hocam burada boş satırları da ciktiya dahil etmez mi

 

[NADİR YILDIZ]

Private Sub CommandButton3_Click()
i = 1
Do While Trim(Cells(i, 8)) = ""
i = i + 1
Loop

ilkb = i
If ilkb > 1 Then ilkb = ilkb - 1
sonb = Cells(Rows.Count, 8).End(3).Row

Range("EB" & ilkb & ":EJ" & sonb).Select
ActiveSheet.PageSetup.PrintArea = "$B$" & ilkb & ":$J$" & sonb

Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$EB$" & ilkb & ":$EJ$" & sonb
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With

C = MsgBox("EB-EJ sütunlarında Dolu Alanlar seçilmiştir." & Chr(8) & Chr(8) _
& "EB-EJ sütunlarında sadece seçili olan Dolu Alanların yazdırılması yapılacak." _
& Chr(10) & Chr(10) & "Onaylıyor musunuz?", vbOKCancel, "Seçili Alanlar Yazdırılacak")

If C = vbCancel Then Exit Sub

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
End Sub

satır sütunları
kendinize göre düzenlersiniz

 

[Muzaffer Ali]

Hocam burada boş satırları da ciktiya dahil etmez mi

Arada boş satırlar olabileceğini söylememiştiniz.
Aşağıdaki kodu deneyin.

Sub Test()
    Dim Alan As Range
    Set Alan = Range("A3:A102").SpecialCells(xlCellTypeBlanks)
    Alan.Rows.Hidden = True
    Range("A3:G" & Cells(Rows.Count, "A").End(xlUp).Row).PrintOut
    Alan.Rows.Hidden = False
End Sub