كود تصدير ملفات PDF لمشتريات كل زبون

[Persl]

السلام عليكم يا اخوان . رمضان مبارك تقبل الله منا و منكم 

 

عندي ملف إكسل فيه صفحة فواتير والخلية

Sheet1 AM1 

 بها قائمة منسدلة وبيانات القائمة المنسدلة عبارة عن اسماء العملاء تؤخذ من صفحة الاندكس 

Index B2:B27

اود لو سمحتو كود في بي إي يعمل على تصدير ملفات بي دي اف لكل زبون له مشتريات 

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

فالشرطين لإصدار بي دي اف هما وجود اسم والاسم يكون قيمة مشترياته اكبر من صفر واذا ما انطبق الشرطين يقوم الكود باصص على الزبون اللي بعدو  

ويسمي كل ملف بالكلام اللي مكتوب في الخلية 

Sheet1 A3

ثم يقوم الكود واخذ كل الملفات اللي أصدرها ويحطها مرفقات في رسالة اوتلك 

Vba code to change drop down list value then extract the sheet to PDF

شاكر لكم جهودكم

هذا نموذج لنفس العمل لكنه مفرغ من البيانات لتقليل حجمه

نموذج.xlsm

[الرائد77]

اليك الكود .  تصدير ملف لكل زبون مهما كان العدد و حفظ باسم الزبون و رقمه .مع امكانية استبدال الملف في حالة وجوده سابقا.  اما بالنسبة لإرساله كرساله. يجب وضع القائمة بالايميلات . و تثبيت outlook . 

يمكنك تغيير مجلد الحفظ في الكود

C:\pdfs

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

نموذج (1).xlsm

[Persl]

عملك ممتاز جدا ولقد قمت بوضع مسار مجلد الحفظ في الكود

C:\Users\persl\Documents\New folder (3)/

وجربت الكود لاصدار الفواتير و الأمور كلها تمام  والفواتير تصدر بشكل ممتاز

 ولكن الشرطين هؤلاء ما يتحققوا في الملف

نلاحظ الملف ينتج فواتير بدون اسم عند الزبون رقم 16 و 17 و18 او الى أسماء ما عليها أي مبالغ مالية مثل الزبون رقم 6 علي صالح

ومن المهم ان الفواتير تكون مع بعض في مرفقات رسالة واحدة و الكود ما يسوي كذا

ارجو التكرم لحل المشكلة

هذا احد الأمثلة 

تم استخدام هذا الكود في الملف السابق ولكنه يصنع عدة رسائل لكل فاتورة رسالة مستقلة وليس رسالة واحدة تحتوي جميع الفواتير كما اود 

Option Explicit

Sub EmailPDF()
   

    Dim EmailSubject As String, EmailSignature As String
    Dim CurrentMonth As String, DestFolder As String, PDFFile As String
    Dim Email_To As String, Email_CC As String, Email_BCC As String
    Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
    Dim OverwritePDF As VbMsgBoxResult
    Dim OutlookApp As Object, OutlookMail As Object
    Dim DVCell As Range
    Dim InputRange As Range
    Dim DV As Range
   
    ' *****************************************************
    ' *****     You Can Change These Variables    *********

    EmailSubject = "Test"   'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = Range("R6").Value   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ""
    Email_BCC = ""
    DestFolder = "C:\Users\persl\Documents\New folder (3)" ' NOTE : There is no trailing slash
          
    ' ******************************************************

    'Which cell has data validation
    Set DVCell = Sheets("Partner Statement").Range("B6")

    'Determine where validation comes from
    Set InputRange = Evaluate(DVCell.Validation.Formula1)
   
    'Prompt for file destination
     With Application.FileDialog(msoFileDialogFolderPicker)

        If .Show = True Then

            DestFolder = .SelectedItems(1)

      Else

           MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"

            Exit Sub

        End If

    End With


    For Each DV In InputRange
   
        DVCell = DV.Value
       
        'Create new PDF file name including path and file extension
        PDFFile = DestFolder & Application.PathSeparator & DV.Value & ".pdf"

        'If the PDF already exists
        If Len(Dir(PDFFile)) > 0 Then
   
            If AlwaysOverwritePDF = False Then
       
                OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
       
                On Error Resume Next
                'If you want to overwrite the file then delete the current one
                If OverwritePDF = vbYes Then
   
                    Kill PDFFile
       
                Else
   
                    MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
               
                    Exit Sub
       
                End If

            Else
       
                On Error Resume Next
                Kill PDFFile
           
            End If
       
            If Err.Number <> 0 Then
       
                MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
               
                Exit Sub
       
            End If
           
        End If
  

        'Create the PDF
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=OpenPDFAfterCreating
           
           
           

        'Create an Outlook object and new mail message
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
       
        'Display email and specify To, Subject, etc
        With OutlookMail
       
            .Display
            .To = Email_To
            .CC = Email_CC
            .BCC = Email_BCC
            .Subject = EmailSubject
            .Attachments.Add PDFFile
               
            If DisplayEmail = False Then
           
                .Display
               
            End If
       
        End With
          
    Next DV
   
End Sub

pgt2-Partner-Statements_SHPP-Fund-I-4.xlsm

[Persl]

دعوني اشارككم اعزائي بآخر المستجدات لعلها تهم احد منكم

نموذج-pgt-1.xlsm