طلب برمجة زر لإزالة فراغات معيبة

[hicham2610]

السلام عليكم

من فضلكم

أحتاج كود vba ليوضع في زر "طبع" ليطبع خلايا جدول بصيغة PDF إلى غاية آخر سطر به بيانات

مثلا الجدول في الجدول الأول : ليطبع من X9 إلى غاية آخر سطر به بيانات وفي هذه الحالةAA35 لأن مثل هذه الجداول تكون بياناتها متغيرة

وجزاكم الله خيرا

ملف.xlsm

[الأستاذ / محمد الدسوقى]

اتفضل استاذ / هشام

جرب الكود التالى إن شاء الله يفى بالغرض المطلوب

انسخ الكود وضعه فى موديول جديد واربطه بزر تنفيذ

Sub MD_To_PDF()
Dim ws As Worksheet
Dim Fname As String
Dim lr       As Long
        Application.ScreenUpdating = False
        
             Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, "X").End(xlUp).Row
'------------------------------------------------
    With ActiveSheet
              On Error Resume Next
              .Range("X9:AA" & lr).Select
            Fname = ThisWorkbook.Path & "\Exported " & ws.Name
            ws.Range("X9:AA" & lr).Select
        Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook _
        .Path & "\" & ActiveSheet.Range("z1").Value & ".pdf", Quality:=xlQualityStandard _
        , IncludeDocProperties:=True, IgnorePrintAreas:=False
    End With
'------------------------------------------------
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[hicham2610]

السلام عليكم

جزاك الله خيرا وأحسن إليك

لكن لم ينجح معي 

هل ستظهر نافذة تطلب مكان حفظ الPDF لأنها لم تظهر معي؟

وجزاكم الله خيرا

 

الجداول المراد طبعها PDF هي الجداول الأربعة التي فوقها:=0 ،   =1  ،   =2   ،  =3

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

Sub IMP_3()
If Not ActiveSheet.Name Like "ÊÑÇßíÈ*" Then Exit Sub 'sécurité
Dim chemin$, rep As Byte, a$, h&, i&
chemin = ThisWorkbook.Path & "\ãáÝ ÍÝÙ ÌÏÇæá ÇáÊÝííÁ\"

If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du dossier
 
        MsgBox "åÔÇã: ÇáÓáÇã Úáíßã¡Êã ÅäÔÇÁ ãáÝ ÍÝÙ ÇáÌÏÇæá Ýí äÝÓ ãßÇä ÊæÇÌÏ ÇáÈÑäÇãÌ Åä áã íßä ãæÌæÏÇ ãÓÈÞÇÈÇÓã:ãáÝ ÍÝÙ ÌÏÇæá ÇáÊÝííÁ."

Application.ScreenUpdating = False
With ActiveSheet
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesTall = 1 '1 page en hauteur, détermine le zoom
    If rep = 6 Then 'Oui
        a = .PageSetup.PrintArea
        h = .Range(a).Rows.Count
        .Copy 'nouveau document
        With ActiveSheet
            .PageSetup.PrintArea = ""
            For i = 1 To Val(.[N7] - 1)
                .Range(a).EntireRow.Offset(h * i - h).Copy .[A1].Offset(h * i)
                .[N5].Offset(h * i) = i + 1
                .HPageBreaks.Add Before:=.[A1].Offset(h * i) 'saut de page
            Next
            .PageSetup.PrintArea = .Range(a).Resize(h * i).Address
            .PageSetup.FitToPagesTall = i
            .ExportAsFixedFormat xlTypePDF, chemin & "Groupé.pdf"
            .Parent.Close False 'fermeture du document
        End With
        MsgBox "åÔÇã: ãÈÑæß¡Êã ÍÝÙ ÇáÌÏÇæá"
    Else 'Non
        For i = 1 To Val(.[N7])
            .[N5] = i
            .ExportAsFixedFormat xlTypePDF, chemin & .[N5] & ".pdf"
        Next
        .[N5] = 1
        MsgBox i - 1 & " :ÚÏÏ ÇáÌÏÇæá ÈÏÅÝ ÇáÊí Êã ÍÝÙåÇ ÈäÌÇÍ åæ"
    End If
End With
End Sub

الكود مدمج في الزر:x9 آسف ظهرت الحروف العربيةبهذا الشكل

وجزاكم الله خيرا

ملف 11.xlsm

تم تعديل يوليو 9, 2019 بواسطه hicham2610

[hicham2610]

السلام عليكم

الإخوة الأفاضل

تمكنت من برمجة أزرار لطبع الجداول  الأربعةبصيغة PDF على سطح المكتب

لكن الغريب أنها تخرج خاطئة(تخص الجدول الأول =3) وناقصة بسطرين من الأعلى ، المرجو التدخل لإصلاح الخلل، وجزاكم الله خيرا

التفييء.xlsm

[بن علية حاجي]

السلام عليكم

جرب الملف المعدل في المرفقات (تم تغيير أمر تحديد نطاقات الجداول في الأكواد بنطاقات ناحية الطباعة مع أمر إلغاء ناحية الطباعة في نهاية كل كود)... أرجو أن يفي الغرض المطلوب...

بن علية حاجي

التفييء.xlsm

[hicham2610]

الأستاذ:بن علية حاجي

جزاك الله خيرا وأتابك الجنة ، هذا ماكنت أبحث عنه

جزاك الله خيرا وأثابك الجنة

 

[hicham2610]

السلام عليكم

لم أفهم ما وقع

كتبت موضوعا جديدا فتم دمجه كرد مع موضوع سابق وتم وضع صور ليوزرفورم لم أدمجها غرييييييب 

سأعدل الموضوع وأفتح موضوعا جديدا 

تم تعديل يوليو 24, 2019 بواسطه hicham2610
أمر غريب

[hicham2610]

السلام عليكم

من فضلكم

كيف أبرمج زر إزالة الفراغات من الجداول الأربعة للفئات الأربعة على اليمين:الأحمر والأزرق والأصفر والأخضر

ليزيل تلك الفراغات المعيبة

وشكرا جزيلا

PROG V11.xlsm

تم تعديل يوليو 24, 2019 بواسطه hicham2610

[hicham2610]

السلام عليكم

هل من اقتراحات إخوتي الكرام؟

 

[hicham2610]

السلام عليكم

توصلت بهذا الحل وتعميما للفائدة أتقاسمه معكم:

Option Explicit

Dim tablo, tabloR()
Dim i&, iR&, j&

Sub SupprimerLesVides()
    
    tablo = Range("X10:AP48")
    ReDim tabloR(1 To UBound(tablo, 1), 1 To UBound(tablo, 2))
    
    For j = 1 To UBound(tablo, 2)
        If j <> 5 And j <> 10 And j <> 15 Then
            iR = 1
            For i = 1 To UBound(tablo, 1)
                If tablo(i, j) <> "" Then
                    tabloR(iR, j) = tablo(i, j)
                    iR = iR + 1
                End If
            Next i
        End If
    Next j
    Range("X10:AP48").ClearContents
    Range("X10").Resize(UBound(tabloR, 1), UBound(tabloR, 2)) = tabloR
    
End Sub

 

[Ali Mohamed Ali]

أحسنت استاذ هشام وأحسن الله اليك