طلب مساعدة في ترحيل بيانات

[Alaa Ammar New]

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

سبق أن رفعت موضوع عن ترحيل بيانات في ملف فعاليات وقد تكرم علي الأخ الفاضل الكريم عبدالله بشير عبدالله بالاستجابة السريعة ونصحني بعمل موضوع جديد لطلب شيء آخر وعلى هذا فما أوده حاليا هو ترحيل البيانات وفصلها في ملف اكسل مستقل وليس شيت جانبي لاني سأرسلها الى جهات مختلفة وكذلك ارجو إلغاء الأسطر الفارغة من الملف المنفصل الناتج عن البحث وازالة السطر العلوي المكتوب فيه "البحث من الى" من الملف المنفصل وكذلك فصله الى ملف بي دي اف لو أمكن.

وجزاكم الله خير الجزاء وزادك من العلم بسطة

acheivements final.xlsb

[محمد هشام.]

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

الاكواد الخاصة بهدا الملف تختلف نوعا ما عن الملف السابق ودالك بتنقيحها بشكل مختلف مع اظافة كود خاص بترحيل ملفات PDF  وانشاء لكل يوم مجلد مستقل 

                              '*****انشاء مجلدات لكل يوم مستقل***
Public Sub Save_folder_PDF()
Dim Path$, sFile$, folderName$, fileName$, fileType$
Dim Cpt As String, PDFfile As String
Dim lastRow As Long, LastCol As Integer
Dim WS As Worksheet: Set WS = printing
Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات"): testDate = Now()
fileType = "تقارير": folderName = "ملفات PDF": sFile = UCase(Format(testDate, "h\hmm")) & " " & "تقرير النشاط"

 Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, ": تأكيد ")
      If Msg <> vbYes Then Exit Sub

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
 WS.Visible = xlSheetVisible

If WorksheetFunction.CountA(printing.Cells) = 0 Then
           MsgBox " ! لا توجد بيانات للحفظ", vbOKOnly + vbInformation
        Exit Sub
    End If
 LastCol = WS.Rows(2).Find("*", WS.Cells(2, WS.Columns.Count), , , , 2).column
 lastRow = WS.Columns(1).Find("*", WS.Cells(WS.Rows.Count, 1), , , , 2).Row
  
  '  Path = "C:" '" قم بتحديد مسار حفظ الملفات على حسب احتياجاتك
     
     ' المسار الافتراضي للملف الرئيسي
     Path = Application.ActiveWorkbook.Path
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    
        Cpt = Path & folderName & "\"
        If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt
        Cpt = Cpt & UCase(Format(Date, "yyyy-mm-dd")) & " " & fileType & "\"
        If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt
        
        PDFfile = Cpt & sFile & ".pdf"
            WS.PageSetup.PrintArea = _
            WS.Range("A2", WS.Cells(lastRow, LastCol)).Address
            
        WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFfile, _
            Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            WS.PageSetup.PrintArea = "": WS.Visible = xlSheetVeryHidden
  
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
     sMsg = "PDF" & " " & "تم حفظ التقرير  بنجاح في مجلد " & "ملفات"
    MsgBox sMsg, vbInformation, " من تاريخ: " & " " & desWS.[d2] & "  " & "إلى تاريخ:" & "  " & desWS.[f2]

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Save_As_PDF()                     'انشاء مجلد في نفس مسار الملف
    Dim sFile As String, sPath As String, fPath As String
    Dim sMsg As String
    Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات")

    Dim F As Worksheet: Set F = printing
    sFile = "تقرير النشاط":      folderName = "ملفات PDF"

Application.ScreenUpdating = False
     Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, F.Name)
      If Msg <> vbYes Then Exit Sub
      F.Visible = xlSheetVisible

 LastCol = F.Rows(2).Find("*", F.Cells(2, F.Columns.Count), , , , 2).column
 lastRow = F.Columns(1).Find("*", F.Cells(F.Rows.Count, 1), , , , 2).Row

    With ActiveWorkbook
        sPath = .Path & Application.PathSeparator & folderName & Application.PathSeparator
        On Error Resume Next
        If Len(Dir(sPath, vbDirectory)) = 0 Then
        End If
        MkDir sPath
        F.PageSetup.PrintArea = _
            F.Range("A2", F.Cells(lastRow, LastCol)).Address
        F.ExportAsFixedFormat Type:=xlTypePDF, _
        fileName:=sPath & Application.PathSeparator & sFile & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        F.PageSetup.PrintArea = ""
        F.Visible = xlSheetVeryHidden
    End With
    sMsg = "PDF" & " " & "تم حفظ التقرير  بنجاح في مجلد " & "ملفات"
    MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & "  " & "إلى تاريخ:" & "  " & desWS.[f2]
        Application.ScreenUpdating = True

End Sub

بالنسبة لكود الفلترة وانشاء ملف Excel مستقل ستجده داخل الملف المرفق 

بالتوفيق ............

 

 

فلترة وحفظ الملفات V2.xlsm

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

[Alaa Ammar New]

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

والله حضرتك انا عاجز عن شكر حضرتك على جام كرمك وسعة صدرك ،

أنا اسف حضرتك هو فيه حاجة صغيرة ، انا عايز احط عنوان للتقرير قبل من احفظه وكل ما ازود صفوف لاعلى بعمل ERROR فهل يمكن اضافة صفين لاعلى لاضافة عنوان مناسب للتقرير؟