Alaa Ammar New قام بنشر April 13 مشاركة قام بنشر April 13 السلام عليكم ورحمة الله وبركاته عندي جدول أدخل فيه بيانات الفعاليات التي تقام في وزارة الثقافة التي اعمل بيها والتي تطلب مني بشكل متكرر ولكن تطلب في اكثر من صورة فهم يطلبون مثلا الانشطة في فترة معينة قد تكون ثلاثة شهور او من اول السنة الى آخرها او من من نصف السنة الى نصف السنة القادمة أي عام مالي حكومي ، ويطلبون تلك الأنشطة في صورة ملف اكسل وملف بي دي إف على سي دي فالمطلوب جزاكم الله كل خير: - البحث عن الانشطة بين فترتين او تاريخين واستخراجها في صفحة اكسل مستقلة وكذلك في صفحة pdf وياريت يكون في خانة اكتب فيه العنوان الذي اريده بحيث بيظهر على الملفين الاكسل وال بي دي اف المصدرين بحيث احفظ الاثنين لوضعهم على اسطوانة. اريد كذلك عمل فلترة وتصفية للجدول بحيث تظهر مواضيع معينة بعينها ، فقط يطلبون الفعاليات التي تتحدث عن المرأة او ذوي الهمم او الذكاء الاصطناعي علشان كده انا وزدت عامود سميته المفتاح بحيث اكتب كلمة تلخص عنوان كل ندوة وهكذا فاريد عمل تصفيه وفلترة لتلك الفعاليات واستخراجهم كذلم الى ملفين واحد اكسل وواحد بي دي اف . - كذلك انا اضع رابط كل فعالية سواء على الفيس او اليوتيوب ولذلك فأن اريد مقترحاتكم و افكاركم في عمل هايبر لينك في صورة متقدمة لان الينكات احيانًا بتضرب . وهل هناك طريقة لاستخراج بيانات من رابط الفيس مثلا اي اني بمجرد وضعه يستخرج بيانات بعنوان الفعالية في خليتها وشكرا مرفق الجدول المراد التعديل عليه وشكرا مقدما إخواتي الكرام acheivements final.xlsx رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر April 13 مشاركة قام بنشر April 13 وعليكم السلام ورحمة الله وبركاته عذرا اخي الفاضل كثرة الطلبات تجعل الكثير لا يكترث بالموضوع لأنه يحتاج الى وقت وجهد فكري فأنصحك ان يكون في موضوعك طلب واحد محدد اذا تم الاجابة علية افتح موضوع جديد واكتب فيه طلبك الثاني وهكذا الطلب الاول تم تنفيذه لك وافر الاحترام acheivements final.xlsb 1 رابط هذا التعليق شارك More sharing options...
Alaa Ammar New قام بنشر April 14 الكاتب مشاركة قام بنشر April 14 (معدل) تمام أخي الحبيب عندك كل الحق كل ما أوده حاليا هو ترحيل البيانات وفصلها في ملف اكسل مستقل وليس شيت جانبي لاني سأرسلها الى جهات مختلفة وكذلك ارجو إلغاء الأسطر الفارغة من الملف المنفصل الناتج عن البحث وازالة السطر العلوي المكتوب فيه "البحث من الى" من الملف المنفصل وكذلك فصله الى ملف بي دي اف لو أمكن. وجزاكم الله خير الجزاء وزادك من العلم بسطة تم تعديل April 14 بواسطه Alaa Ammar New رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر April 14 مشاركة قام بنشر April 14 (معدل) اتمنى ان يكون طلبك في هذا الملف يتم تكوين مجلدين احدهما باسم باسم تقرير اكسل والاخر تقرير PDF في نفس مجلد الملف الرئيسي الكودين لاستاذنا المبدع محمد هشام اكسل وPDF.xlsb تم تعديل April 14 بواسطه عبدالله بشير عبدالله رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر April 15 مشاركة قام بنشر April 15 (معدل) السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم 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 بواسطه محمد هشام. 3 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها