لدي مشكلة في كود الطباعة

[Khorsheed Omar]

السلام عليكم 

لدي ملف و فيه 6 وصولات قبض او صرف للطباعة و لدي ازرار لطباعة كل وصل

لكن احتاج كود للطباعة واحد فقط و عند الضغط عليه يطلب مني اختيار الوصولات لطباعتها

مثال.xlsm

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

حسب فهمى لطلبك اليك الملف

مثال (1).xlsm

 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

حاول دمج الأكواد السابقة في كود واحد لتتمكن من طباعة وصل معين أو عدة وصولات من إختيارك بالطريقة التالية 

Sub Choose_the_print()

    Dim tmp As Variant, arr As Variant, n As Range
    Dim OnRng As String, xInput As String, a(1 To 6) As String
    Dim WS As Worksheet: Set WS = Sheets("ورقة1")
    
    a(1) = "H2:L16":   a(2) = "N2:R16":  a(3) = "T2:X16":
    a(4) = "H18:L32":  a(5) = "N18:R32": a(6) = "T18:X32"

    xInput = InputBox("يرجى إدخال أرقام الوصولات للطباعة" & vbCrLf & "مفصولة بفاصلة (-) مثل: 3-2-1", "إختيار الوصولات")
    
    If Trim(xInput) = "" Then: MsgBox "لم يتم إدخال أي أرقام يرجى المحاولة مرة أخرى", vbExclamation: Exit Sub

    tmp = Split(xInput, "-")
    For Each arr In tmp
        If IsNumeric(Trim(arr)) Then
            If Val(arr) >= 1 And Val(arr) <= 6 Then
                OnRng = a(Val(arr))
                Set n = WS.Range(OnRng)
                n.PrintOut Copies:=1, Collate:=True
            Else
                MsgBox "رقم الوصل " & arr & " غير موجود يرجى التأكد", vbExclamation
                Exit Sub
            End If
        Else
            MsgBox "إدخال خاطئ " & arr, vbExclamation
            Exit Sub
        End If
    Next arr

    MsgBox "تمت الطباعة بنجاح", vbInformation
End Sub

 

مثال.xlsm

تم تعديل يناير 26, 2025 بواسطه محمد هشام.

[Khorsheed Omar]

شكرا جزيلا استاذ @عبدالله بشير عبدالله و ايضاً الشكر للأستاذ @محمد هشام.

الطريقتين صحيحتين و استفيد منهما 

[Khorsheed Omar]

لدي تكملة لسؤالي ان امكن لي و اعتذر عن الإطالة استاذ @عبدالله بشير عبدالله و الأستاذ @محمد هشام.

الطباعة تتم بأكمل وجه لكن اريد بعض الخيارات في الطباعة و لا استطيع اضافتها مثل ازالة الهوامش و طباعة التحديد فقط حتى لو كانت الورقة كبيرة

Range("Q2:Y20").Select
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    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
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .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
    Application.PrintCommunication = True
    Selection.PrintOut Copies:=1, Collate:=True
End Sub