بحث وترحيل بيانات بين تاريخين

[Alaa Ammar New]

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

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

فالمطلوب جزاكم الله كل خير:
 - البحث عن الانشطة بين فترتين او تاريخين واستخراجها في صفحة اكسل مستقلة وكذلك في صفحة pdf وياريت يكون في خانة اكتب فيه العنوان الذي اريده بحيث بيظهر على الملفين الاكسل وال بي دي اف المصدرين بحيث احفظ الاثنين لوضعهم على اسطوانة.
اريد كذلك عمل فلترة وتصفية للجدول بحيث تظهر مواضيع معينة بعينها ، فقط يطلبون الفعاليات التي تتحدث عن المرأة او ذوي الهمم او الذكاء الاصطناعي علشان كده انا وزدت عامود سميته المفتاح بحيث اكتب كلمة تلخص عنوان كل ندوة وهكذا فاريد عمل تصفيه وفلترة لتلك الفعاليات واستخراجهم كذلم الى ملفين واحد اكسل وواحد بي دي اف .
- كذلك انا اضع رابط كل فعالية سواء على الفيس او اليوتيوب ولذلك فأن اريد مقترحاتكم و افكاركم في عمل هايبر لينك في صورة متقدمة لان الينكات احيانًا بتضرب .
وهل هناك طريقة لاستخراج بيانات من رابط الفيس مثلا اي اني بمجرد وضعه يستخرج بيانات بعنوان الفعالية في خليتها وشكرا

مرفق الجدول المراد التعديل عليه

وشكرا مقدما إخواتي الكرام

acheivements final.xlsx

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

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

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

الطلب الاول تم تنفيذه 

لك وافر الاحترام

 

acheivements final.xlsb

[Alaa Ammar New]

تمام أخي الحبيب عندك كل الحق

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

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

تم تعديل April 14 بواسطه Alaa Ammar New

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

اتمنى ان يكون طلبك في هذا الملف  يتم تكوين مجلدين احدهما باسم باسم تقرير اكسل والاخر تقرير PDF في نفس مجلد الملف الرئيسي  الكودين لاستاذنا  المبدع محمد هشام

اكسل وPDF.xlsb

تم تعديل April 14 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك 

هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing 

Sub FilterByDate()
Dim WS  As Worksheet: Set WS = Worksheets("Sheet1")
Dim desWS As Worksheet: Set desWS = Sheets("الانشطة")
Dim f As Worksheet: Set f = printing
Dim MinDate As Date, MaxDate As Date, lr As Long
Dim a As Range, r As Long

MinDate = desWS.[d2]: MaxDate = desWS.[f2]
Application.ScreenUpdating = False

If MinDate > MaxDate Then: Exit Sub
If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then

If WS.AutoFilterMode Then WS.AutoFilterMode = False
With WS.Range("A7:K7")
.AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate)

lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible)
    If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then
        desWS.Range("A5:K" & Rows.Count).Clear

With rng
    Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",")
    Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",")
For i = LBound(Cpt) To UBound(Cpt)
WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5")
           Next i
 End With
    lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))"
        Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))"
 With desWS
        .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2
        .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value
 End With
End If
  .AutoFilter
  End With
  f.Range("A2:K" & f.Rows.Count).Clear
  Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp))
  For r = 1 To 11
    Set a = Union(a, Intersect(a.EntireRow, Columns(r)))
  Next r
  a.Copy Destination:=f.Range("a2")
  End If
Application.ScreenUpdating = True
End Sub

لحفظ الملف بصيغة PDF

Sub Save_folder_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
    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.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1

        f.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        f.Visible = xlSheetVeryHidden
    End With
    sMsg = "PDF" & " " & "تم حفظ التقرير  بنجاح في مجلد " & "ملفات"
    MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & "  " & "إلى تاريخ:" & "  " & desWS.[f2]
        Application.ScreenUpdating = True

End Sub

لحفظ التقرير في ملف مستقل 

Sub Save_folder_Excel()
Dim WS As Worksheet: Set WS = printing
Dim desWS As Worksheet: Set desWS = Sheets("الانشطة")
Dim path As String, folderName As String, sMsg As String
Dim newWb As Workbook, Fname As String

path = ThisWorkbook.path & "\"
On Error Resume Next
      Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name)
      If Msg <> vbYes Then Exit Sub
      
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
 WS.Visible = xlSheetVisible
folderName = "ملفات Excel"
MkDir path & folderName
Fname = folderName & "\" & WS.Name
WS.Copy
Set newWb = ActiveWorkbook
newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51
newWb.Close
WS.Visible = xlSheetVeryHidden
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
On Error GoTo 0
    sMsg = "Excel" & " " & "تم حفظ التقرير  بنجاح في مجلد " & "ملفات"
    MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & "  " & "إلى تاريخ:" & "  " & desWS.[f2]
End Sub

 

 

فلترة وحفظ PDF +EXCEL.xlsm

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