تجميع فواتير فى ملف pdf واحد

[عادل ابوزيد]

السلام عليكم .. وكل عام وحضراتكم بالف خير وصحة وعافية

لقد بحث فى المنتدى كثيرا وهناك مواضيع مشابه لمثل هذا الموضوع إلا اننى لم اتمكن من تطبيقه على ملفى حيث فى الملف المرفق به كود يقوم بانشاء عدد من ملفات pdf كل ملف ياخذ اسم الخلية cc332 بعدد الارقام الموجود من الخلية ca328 حتى الخلية ce328 بداخل فولدر باسم raed ويجب انشاؤه قبل تنفيذ الماكرو ومدى الملف من be330 : ck372
المطلوب :
تجميع الفواتير هذه فى ملف واحد ياخذ اسم محتوى الخلية bx328 (برجاء جعل التاريخ يظهر بهيئة يوم / شهر / سنة وليس كما بالخلية )

والكود نفسه يقوم بانشاء فولدر لهذا الملف 

تقبلوا تحياتى 

Book2.xls

[محمد هشام.]

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

تفضل اخي جرب هدا  (تم اظافة ورقة جديدة مخفية على الملف باسم PDF  لتجميع الفواتير

9 ساعات مضت, عادل ابوزيد said:

مدى الملف من be330 : ck372

اظن ان مدى بيانات الفاتورة غير مطابق لما كتبته هنا ادا لم اكن مخطئ 

 

Sub svPDF()
Dim MyRng As Range, r As Long, i As Integer, LR As Long
Dim fRow, Cpt As Range, FndRng As Range, myValue As String
Dim sFile As String, FolderName As String

Set desWS = Sheet79: Set WS = PDF
Set MyRng = desWS.[BW330:CK372]
minDate = Format(desWS.[DC330], "yyyy-mm-dd"): maxDate = Format(desWS.[CV330], "yyyy-mm-dd")

'قم بتحديد مسار حفظ الملف بما يناسبك
 'Path = "C:"

' المسار الافتراضي للملف الرئيسي
Path = Application.ActiveWorkbook.Path

'اسم الملف المستخرج
sFile = minDate & " " & "الفواتير من" & " " & maxDate & " " & "الى"
' اسم مجلد الحفظ
FolderName = "raed":

'شرط فواصل الصفحات
myValue = "اجمالى الواصل"
 
 If Len(desWS.[CA328].Value) = 0 Then Exit Sub

Application.ScreenUpdating = False
On Error Resume Next
 WS.Visible = xlSheetVisible: WS.Cells.Clear
For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i
With ActiveWorkbook
        sPath = Path & Application.PathSeparator & FolderName & Application.PathSeparator
        If Len(Dir(sPath, vbDirectory)) = 0 Then
        End If
        MkDir sPath

MyRng.Copy
LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 4
  With WS.Range("A" & LR)
    .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
     Application.CutCopyMode = False
    End With
  End With
 Next i
 
With WS
fRow = .Range("a:o").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set FndRng = .Range("j10:j" & fRow)
Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _
                       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not Cpt Is Nothing Then: Linge = Cpt.Address
Do
If Not Cpt Is Nothing Then: Cpt.Offset(2).PageBreak = xlPageBreakManual
 Set Cpt = FndRng.FindNext(Cpt)
   If Cpt Is Nothing Then: Exit Do
     If Cpt.Address = Linge Then: Exit Do
   Loop
 WS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
 End With
WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & Application.PathSeparator & sFile & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        WS.Visible = xlSheetVeryHidden
 On Error GoTo 0
 Application.ScreenUpdating = True
End Sub

 

Book2.xls

تم تعديل April 18 بواسطه محمد هشام.

[عادل ابوزيد]

الاستاذ الفاضل محمد هشام 

اشكرك حضرتك على الاهتمام وسرعة الرد على الموضوع واسمح لى لتجميل العمل ان تنظر الى هذه الكلمات :
1 -ان يكون ملف الPDFكل صفحة فيه تظهر الفاتورة كاملاً من المدى ( bw330:ck372) 
2 - الملف الاصلى يتعامل مع اسابيع بمعنى يتم انشاء شيت لكل اسبوع وبالتالى هناك فواتير خاصة بكل اسبوع لذا تم استحداث شيت باسم فواتير الاسبوع برجاء استكمال الكود لترحيل الفواتير بجوار بعضها كما هو موضح بالشيت
3 - تم تفسير بعض اجزاء الكود برجاء استكمال باقى الاجزاء

Book2بالتعديل.xls

[عادل ابوزيد]

up

[محمد هشام.]

في 18‏/4‏/2024 at 17:49, عادل ابوزيد said:

-ان يكون ملف الPDFكل صفحة فيه تظهر الفاتورة كاملاً من المدى ( bw330:ck372) 

1) صراحة لم استوعب طلبك هل هو تعديل للكود الاول او طلب مغاير لان الكود يقوم بنفس الشيء

 

في 18‏/4‏/2024 at 17:49, عادل ابوزيد said:

الملف الاصلى يتعامل مع اسابيع بمعنى يتم انشاء شيت لكل اسبوع وبالتالى هناك فواتير خاصة بكل اسبوع لذا تم استحداث شيت باسم فواتير الاسبوع برجاء استكمال الكود لترحيل الفواتير بجوار بعضها كما هو موضح بالشيت

المرجوا ارفاق عينة للنتائج المتوقعة بعد الترحيل وبعد الطباعة ربما نستطيع مساعدتك 

 

 

 

[عادل ابوزيد]

السلام عليكم استاذى الفاضل سلمت يداك ولكن احب اوضح

1 - الكود الاول لعمل ملف الـ PDF شكل الفواتير بالملف غير مجمع بمعنى ان الفاتورة بتكون ناقصة بتظهر نصفها والنصف الاخر فى وسط الملف .. حاولت اغير من اعدادات الورقة المسماه بـ PDF ولم تفلح التجربة .. برجاء الاطلاع عليها 

2  - كود الترحيل الذى تفضلتم بعمله رائع ولكن ما اريده ان هذا الكود سيتم استخدامه اكثر من مرة بعدد اسابيع العام والمراد اظهار هذه الفواتير فى شيت واحد وضعت تصورى فى شيت باسم الشكل المطلوب ( ممكن حضرتك تضع تصور اخر يلبى ما ابغيه ، ما فيش مشكلة المهم ان فواتير السنة كلها تظهر فى شيت واحد ) هذا بخلاف شيت الPDF الخاص بالطباعة 

3 - برجاء استكمال شرح كود الPDF

Book22بالتعديل.xls

[عادل ابوزيد]

تم رفع ملف به شكل اخر للمطلوب وشرح اكثر استفاضة

Book222بالتعديل.xls

[محمد هشام.]

في 24‏/4‏/2024 at 09:18, عادل ابوزيد said:

لكود الاول لعمل ملف الـ PDF شكل الفواتير بالملف غير مجمع بمعنى ان الفاتورة بتكون ناقصة بتظهر نصفها والنصف الاخر فى وسط الملف

تقصد ان هدا الشكل لا يناسبك

في 24‏/4‏/2024 at 09:18, عادل ابوزيد said:

2  - كود الترحيل الذى تفضلتم بعمله رائع ولكن ما اريده ان هذا الكود سيتم استخدامه اكثر من مرة بعدد اسابيع العام والمراد اظهار هذه الفواتير فى شيت واحد وضعت تصورى فى شيت باسم الشكل المطلوب ( ممكن حضرتك تضع تصور اخر يلبى ما ابغيه ، ما فيش مشكلة المهم ان فواتير السنة كلها تظهر فى شيت واحد ) هذا بخلاف شيت الPDF الخاص بالطباعة

هل قمت بتجربة هدا 

Sub test()
Dim lCol As Long, MyRng As Range
Set desWS = ActiveSheet: Set ws = Sheet2
If Len(desWS.[CA328].Value) = 0 Then Exit Sub

ws.Cells.Clear
For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i
Set MyRng = desWS.[BW330:CK372]
Application.ScreenUpdating = False

MyRng.Copy

    If ws.[D9] = "" Then
        MyRng.Copy
        With ws.[c5]
            .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
        End With
    Else
        lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column + 5
        MyRng.Copy
        With ws.Cells(5, lCol)
        .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
        End With
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
Next i
End Sub

 

2024-04-11 الفواتير من 2024-04-05 الى.pdf

[عادل ابوزيد]

السلام عليكم .. استاذى الفاضل الكود السابق يقوم بمسح الورقة قبل الترحيل وبالتالى ما سيتم اظهاره هو الترحيل الخاص بالاسبوع الحالى فقط اما الترحيلات السابقة فلن تظهر

والمطلوب ان كل اسبوع يتم ترحيله لا يتم مسح الترحيلات السابقة  واظهار النتائج ( هناك شكلين كما ييسر ) كما بالملف التالى

Book222بالتعديل.xls

[محمد هشام.]

  اسف اخي على التاخير في الرد بسبب ظروف العمل وضيق الوقت لدي 

تفضل  جرب هدا حاولت تعديل الاكواد قدر المستطاع للحصول على نفس الشكل المطلوب  اتمنى ان يلبي طلبك 

 

 

Book معدل.xls

تم تعديل منذ 7 ساعات بواسطه محمد هشام.