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

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

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

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

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

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

Book2.xls

[محمد هشام.]

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

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

في 17‏/4‏/2024 at 18:51, عادل ابوزيد 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