رجاء تعديل أخير على ترحيل بيانات

[Alaa Ammar New]

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

أساتذتي الكرام محمد هشام.  @عبدالله بشير عبداللهجزاكم الله كل خير ويعجز لكلام عن شكركم

هذا الملف من تعديل أستاذنا محمد هشام.  جزاه الله عنا خير الجزاء

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

مستقلين اكسل وبي دي اف - بمعني عايز النتيجة تشمل نتيجة الفلترة اللي هاعملها للجدول الرئيسD في SHEET1 بحيث بعد الفلتروة في SHEET1 عايز نتيجة لفلترة برضه تتفصل زي الفترة اللي بين التاريخين

ومعلش الملف الاكسل او البي دي اف عايز احط ليهم عنوان فهل ينفع وجود خانة لاضافة العنوان لاني كل ما بزود سطر في الاعلى بيدي ERROR

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

وياريت معلش أخيرا عايز احط فيه كود عمل نسخة احتياطية في مكان وليكن في الD في مجلد اسمه Buckup كل فترة من الوقت ..

أرجو التعديل بعد اذن حضراتكم على الملف المرفق والمعدل من قبل الأستاذ محمد هشام. زاده الله علما وجزاه الله خيرا

 

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

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

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

[محمد هشام.]

جرب هدا 

Private Sub TextBox1_Change()
Set WS = Sheets("Sheet1")
On Error Resume Next
If WS.TextBox1.Text = Empty Then WS.[A8:L8].AutoFilter
lr = WS.Cells(WS.Rows.Count, "L").End(xlUp).Row
Clé = "*" & Replace(WS.TextBox1.Text, " ", "*") & "*"
   
If WS.TextBox1.Text <> "" Then
Set rng = WS.Range("A8:L" & lr)
 
 '****المفتاح*****
 
 rng.AutoFilter field:=12, Criteria1:=Clé

'******* اظافة شرط بين تاريخين

rng.AutoFilter field:=3, _
     Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _
                        Criteria2:="<=" & CDbl(WS.[F4])
     
   Else
  WS.[A8:L8].AutoFilter

  End If
End Sub

 

Sub test()
Dim desWS As Worksheet: Set desWS = Sheets("Sheet1")
Dim dest As Worksheet: Set dest = printing

Application.ScreenUpdating = False

If Sheets("Sheet1").TextBox1.Text = "" Then Exit Sub

rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000"))
               
   If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub
   
Set a = desWS.Range("A8", desWS.Range("A" & desWS.Rows.Count).End(xlUp))
 ' For r = 1 To 11 لغاية عمود الملاحظات
  For r = 1 To 12    'مفتاح ' لغاية عمود
    Set a = Union(a, Intersect(a.EntireRow, a.Columns(r)))
  Next r
 Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name)
      If Msg <> vbYes Then Exit Sub
  dest.Range("A3:L" & dest.Rows.Count).Clear
  a.Copy Destination:=dest.Range("A6")
  'حفظ PDF
  Save_As_PDF2
  On Error Resume Next
   desWS.AutoFilter = False
   Sheets("Sheet1").TextBox1.Text = ""
   Application.ScreenUpdating = True
End Sub

 

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

[Alaa Ammar New]

استاذي محمد هشام. ربنا يكرمك يارب على كرم حضرتك الكبيير ويارب يجعل ما تفعله في ميزان حسناتك .. الحمد لله عرفت اشغله

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

وياريت حضرتك معلش كود عمل نسخة احتياطية كل عشر دقائق في D:/BACKUPS  للملف كله

محمد هشام. ربنا يحفظ حضرتك يا رب العالمين

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

[محمد هشام.]

11 ساعات مضت, Alaa Ammar New said:

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

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

'******* اظافة شرط بين تاريخين

rng.AutoFilter field:=3, _
     Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _
                        Criteria2:="<=" & CDbl(WS.[F4])

اما بالنسبة ل كود عمل نسخة احتياطية كل عشر دقائق 

ضع الكود التالي في  module 

Sub SaveBackup()
  
    Dim filePath$,folderName$,copyName$
     Dim ThisBook As Workbook :   Set ThisBook = ThisWorkbook
    
    'مسارالحفظ  '     
 filePath = "D:":            

'اسم مجلد الحفظ
folderName = "BACKUPS"
     
     With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    
    On Error Resume Next
    copyName = filePath & "\" & folderName & " " & _
                     Format(Now, "dd-mmmm-yyyy")
     
'انشاء مجلد الحفظ في حالة عدم العثور عليه                
     If Dir(copyName, vbDirectory) = "" Then MkDir copyName
    ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _
                       Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm"
 
 ' قم بتعديل وقت الحفظ بما يناسبك
      Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup"
      
      'حفظ المصنف الرئيسي
      ' ActiveWorkbook.Save
        
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
   
End Sub

وفي حدث  Private Sub Workbook_Open

Private Sub Workbook_Open()
Call SaveBackup
End Sub

تفضل جرب المرفق التالي

 

بالتوفيق

 

فلترة وحفظ.xlsm

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

[alliiia]

الله ينفع بك أستاذنا محمد هشام

تم تعريف المتغيرات حتى لا تحصل مشاكل مستقبلية

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

 

 

Sub SaveBackup()

    Dim filePath As String
    Dim FolderName As String
    Dim copyName As String
    Dim ThisBook As Workbook
    Set ThisBook = ThisWorkbook
    
    ' هنا سيتم الحصول على مسار الجهاز 
    filePath = Environ("UserProfile") & "\Desktop"
 

    FolderName = "BACKUPS"
     
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False

    copyName = filePath & "\" & FolderName & " " & Format(Now, "dd-mmmm-yyyy")
 

    If Dir(copyName, vbDirectory) = "" Then MkDir copyName
    ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _
                       Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm"
 

    Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup"

    .DisplayAlerts = True
    .ScreenUpdating = True
    End With
   
End Sub
 

[Alaa Ammar New]

سيدي الفاضل @محمد هشام. نفع الله بك وزادك الله من علمه

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

أنا سيدي آسف جدا ولكني أرجو منك ضافة تصدير الى EXCLE بجانب حفظ PDF .

جزاك الله كل خير سيدي الكريم فأنت أخي في الله

 

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

[محمد هشام.]

4 ساعات مضت, Alaa Ammar New said:

أرجو منك ضافة تصدير الى EXCLE بجانب حفظ PDF .

لم تدكر اخي ما هو النطاق المطلوب 

تفضل جرب هل هدا ما تقصده 

Sub CopySheet()                           
Dim filePath$, folderName$, Fname$
Dim rCopy As Range, rng As Range
Dim lRow As Long, i As Integer
Dim wbSource As Workbook

Set wbSource = ThisWorkbook
Set WS = wbSource.Worksheets("Sheet1")
    lRow = WS.Range("B" & WS.Rows.Count).End(xlUp).Row
     Set rCopy = WS.Range("A7:K" & lRow).SpecialCells(xlCellTypeVisible)

folderName = "ملفات Excel"
Fname = "تقرير النشاط"
filePath = ThisWorkbook.path & "\" & folderName
On Error Resume Next
'OR
    'filePath = "D:" & "\" & folderName

If WS.Range("L9:L" & lRow).SpecialCells(xlCellTypeVisible).Count > 1 Then

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .CopyObjectsWithCells = False
    
  Set newWb = Workbooks.Add: Set SH = newWb.Sheets(1)
  rCopy.Copy Destination:=SH.Range("A3")
  
    LastR = SH.Range("A" & SH.Rows.Count).End(xlUp).Row
        SH.Range("A7:A" & LastR).RowHeight = 28
    
    For i = 1 To 11
        Columns(i).ColumnWidth = WS.Columns(i).ColumnWidth
    Next i
 SH.[A5] = 1: SH.Range("A5:A" & SH.Cells(Rows.Count, 2).End(3).Row).DataSeries , xlLinear
'Columns(1).Delete
If Dir(filePath, vbDirectory) = "" Then MkDir filePath
newWb.SaveAs fileName:=filePath & "\" & Fname & ".xlsx", FileFormat:=51
newWb.Close

 .CopyObjectsWithCells = True
 .DisplayAlerts = True
 .ScreenUpdating = True
End With

    sMsg = "Excel" & " " & "تم حفظ التقرير  بنجاح في مجلد " & "ملفات"
    MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & WS.[D4] & "  " & "إلى تاريخ:" & "  " & WS.[F4]
    Else

MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء"
End If
End Sub

 

فلترة وحفظ.xlsm

[Alaa Ammar New]

والله حضرتك انا عاجز جدا عن شكر سيادتك ربنا يجعله في ميزان حسناتك يارب جزاك الله خير الجزاء

اسمحلي حضرتك لو فيه اي سؤال تاني ليا ابقى اسألهولك في موضوع منفصل وكلي ثقة في كرم حضرتك

 

[محمد هشام.]

3 ساعات مضت, Alaa Ammar New said:

اسمحلي حضرتك لو فيه اي سؤال تاني ليا ابقى اسألهولك في موضوع منفصل

بكل سرور اخي @Alaa Ammar New  يسعدنا اننا استطعنا مساعدتك