نجوم المشاركات

حل اخر في حالة الرغبة بمسح البيانات القديمة وترحيل الجديدة Sub Sheets_Arrays2() ' بالتنسيقات Dim LR&, LR2&, lrow& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lRow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lRow).ClearContents For Each wsData In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) a = wsData.Cells(Rows.Count, "E").End(xlUp).Row b = Dest.Cells(Rows.Count, "C").End(xlUp).Row wsData.Range("E10:F" & a).Copy Dest.Range("C" & b + 1) wsData.Range("H10:H" & a).Copy Dest.Range("E" & b + 1) wsData.Range("J10:J" & a).Copy Dest.Range("F" & b + 1) wsData.Range("L10:M" & a).Copy Dest.Range("G" & b + 1) wsData.Range("P10:Q" & a).Copy Dest.Range("I" & b + 1) Application.ScreenUpdating = True Next wsData End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' قيم Sub Sheets_Arrays3() Dim LR&, LR2& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lrow).ClearContents For Each wsData In Sheets(Array("sheet1", "sheet2", "sheet3")) LR = wsData.Cells(Rows.Count, "E").End(xlUp).Row LR2 = Dest.Cells(Rows.Count, "C").End(xlUp).Row + 1 With wsData Dest.Range("C" & LR2 & ":d" & LR2 + LR - 10).Value = wsData.Range("E10:F" & LR).Value Dest.Range("E" & LR2 & ":e" & LR2 + LR - 10).Value = wsData.Range("H10:H" & LR).Value Dest.Range("F" & LR2 & ":F" & LR2 + LR - 10).Value = wsData.Range("J10:J" & LR).Value Dest.Range("G" & LR2 & ":h" & LR2 + LR - 10).Value = wsData.Range("L10:M" & LR).Value Dest.Range("I" & LR2 & ":j" & LR2 + LR - 10).Value = wsData.Range("P10:Q" & LR).Value End With Application.ScreenUpdating = True Next wsData End Sub عيد مبارك سعيد2.xlsm

وعليكم السلام ورحمة الله وبركاته أتمنى أن يفيد هذا Sub TR7el() Dim ro, ro4 As Long ro = Worksheets(1).Range("C" & Rows.Count).End(xlUp).Row Worksheets(1).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _ Worksheets(4).Range("c10") ro = Worksheets(2).Range("C" & Rows.Count).End(xlUp).Row ro4 = Worksheets(4).Range("C" & Rows.Count).End(xlUp).Row + 1 Worksheets(2).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _ Worksheets(4).Range("c" & ro4) ro4 = Worksheets(4).Range("C" & Rows.Count).End(xlUp).Row + 1 ro = Worksheets(3).Range("C" & Rows.Count).End(xlUp).Row Worksheets(3).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _ Worksheets(4).Range("c" & ro4) End Sub كل عام وانت بخير.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arr() Dim a, b, C As Variant, lr& Dim Dest As Worksheet: Set Dest = Sheets("eman") 'Columns : E,F,H,L,M,P,Q Const r As String = "5 6 8 10 12 13 16 17 " For Each C In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) lastrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Row + 1 Application.ScreenUpdating = False lr = C.Columns("A:Q").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = Evaluate("row(10:" & lr + 10 & ")") b = Split(r) Dest.Range("c" & lastrow).Resize(lr, UBound(b)).Value = Application.Index(C.Cells, a, b) Application.ScreenUpdating = True Next C End Sub عيد مبارك سعيد.xlsm

بالمعادلات كل عام وانت بخير(1).xlsm بالمعادلات

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton1_Click() TextBox2.Value = Format(Range("A2").Value, "dd/mm/yyyy") End Sub

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

وعليكم السلام 🙂 المشكلة ليست في هذا السطر ، وانما في تصريح مكتبة الوندوز SetWindowsHookEx جرب واعمل هذا التغيير : #if win64 then public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr #else public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long #endif

السلام عليكم 🙂 مجرد اقتراح ، وعملته ببرنامج الصور 🙂 بما ان عدد التخصصات قد يزيد ، ولا تتسع له الصفحة ، فاقترح ان يكون تقريرك بالطول ، هكذا (طبعا بتعديل المسميات والارقام 🙂 ) :

جرب المرفق باضافة بعض المطاطعات والوظائف .... وأعلمنا بالنتيجة . ‏‏‏‏‏‏‏‏‏‏‏‏BASEN_2.accdb

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

طيب جرب DoCmd.DeleteObject acTable, "data" DoCmd.TransferDatabase acImport, "Microsoft Access", _ "C\Updatedata\ser.mdb", acTable, "data", "data", False بالتوفيق كل عام و أنتم بخير

قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف هذا الموضوع مخالف لقوانين المنتدي ×××××××× يخالف حقوق الملكية الفكرية ×××××××× يغلق ×××××××× الإدارة

تفضل اخي لاظهار اسماء اوراق العمل او اخفائها استخدم الكود التالي Sub Show_and_hide_sheets() If ActiveWindow.DisplayWorkbookTabs = False Then ActiveWindow.DisplayWorkbookTabs = True Else ActiveWindow.DisplayWorkbookTabs = False End If End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub Filtre() Dim ws1 As Worksheet: Set ws1 = Sheets("Raw Data") Dim ws2 As Worksheet: Set ws2 = Sheets("list filter") Application.ScreenUpdating = False On Error Resume Next ws1.ShowAllData '(B)'المعيار الاول عمود '--- Iso_Spool n = Application.CountA(ws2.Range("A2:A5")) If n > 0 Then Tbl = Application.Transpose(ws2.[A2].Resize(n)) ws1.[A4].AutoFilter Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues End If '(C)'المعيار الثاني عمود '--- Spool2 n = Application.CountA(ws2.Range("B2:B5")) If n > 0 Then Tbl = Application.Transpose(ws2.[B2].Resize(n)) ws1.[A4].AutoFilter Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues End If '(E)'المعيار الثالث عمود '--- IdentCode n = Application.CountA(ws2.Range("C2:C5")) If n > 0 Then Tbl = Application.Transpose(ws2.[C2].Resize(n)) ws1.[A4].AutoFilter Field:=5, Criteria1:=Tbl, Operator:=xlFilterValues End If End Sub TEST V3.xlsm

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

تسلم استاذنا الفاضل الف الف شكر وفقك الله واسعدايامك .

أعتذر السبب هو الفرق في تنسيق التاريخ وتقويم اللغة على الجهاز قم بتغييرها فقط إلى =IF($F$10<>"";"30/"&TEXT($F$10;"mm/aaaa");"") طلبك يتمثل في كتابة اي تاريخ بالنسبة لاقتراح الاخ @أبوأحـمـد ممكن يفيدك لاكن مشكلته عند تغيير التاريخ الى شهر 2 لن يشتغل معك بالشكل الصحيح .عكس المعادلة الأولى DATE 30-2.xlsm

كود راسبون لايعمل sheet-5.xlsb

تفضل أخي العزيز .. ولزيادة الخير وضعت لك أكواد جميع الإجراءات الأساسية : الإجراءات الإعتيادية للسجلات ( حفظ - جديد - حذف - إضافة - تكرار - التالي - السابق - الأول - الأخير - .....) '===================================== حفظ السجل والذهاب لسجل جديد Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord DoCmd.GoToRecord , , acNewRec Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== حذف السجل Private Sub DeleteBtn_Click() On Error GoTo Err_DeleteBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdDeleteRecord Exit_DeleteBtn_Click: Exit Sub Err_DeleteBtn_Click: MsgBox Err.Description Resume Exit_DeleteBtn_Click End Sub '===================================== إضافة سجل جديد Private Sub AddNewBtn_Click() On Error GoTo Err_AddNewBtn_Click DoCmd.GoToRecord , , acNewRec Exit_AddNewBtn_Click: Exit Sub Err_AddNewBtn_Click: MsgBox Err.Description Resume Exit_AddNewBtn_Click End Sub '===================================== السجل التالي Private Sub NextBtn_Click() On Error GoTo Err_NextBtn_Click DoCmd.GoToRecord , , acNext Exit_NextBtn_Click: Exit Sub Err_NextBtn_Click: MsgBox Err.Description Resume Exit_NextBtn_Click End Sub '===================================== السجل السابق Private Sub PreviousBtn_Click() On Error GoTo Err_PreviousBtn_Click DoCmd.GoToRecord , , acPrevious Exit_PreviousBtn_Click: Exit Sub Err_PreviousBtn_Click: MsgBox Err.Description Resume Exit_PreviousBtn_Click End Sub '===================================== السجل الأول Private Sub FirstBtn_Click() On Error GoTo Err_FirstBtn_Click DoCmd.GoToRecord , , acFirst Exit_FirstBtn_Click: Exit Sub Err_FirstBtn_Click: MsgBox Err.Description Resume Exit_FirstBtn_Click End Sub '===================================== السجل الأخير Private Sub LastBtn_Click() On Error GoTo Err_LastBtn_Click DoCmd.GoToRecord , , acLast Exit_LastBtn_Click: Exit Sub Err_LastBtn_Click: MsgBox Err.Description Resume Exit_LastBtn_Click End Sub '===================================== البحث عن سجل Private Sub FinedRecBtn_Click() On Error GoTo Err_FinedRecBtn_Click Screen.PreviousControl.SetFocus DoCmd.RunCommand acCmdFind Exit_FinedRecBtn_Click: Exit Sub Err_FinedRecBtn_Click: MsgBox Err.Description Resume Exit_FinedRecBtn_Click End Sub '===================================== تكرار السجل Private Sub DublicateRecBtn_Click() On Error GoTo Err_DublicateRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Exit_DublicateRecBtn_Click: Exit Sub Err_DublicateRecBtn_Click: MsgBox Err.Description Resume Exit_DublicateRecBtn_Click End Sub '===================================== حفظ السجل Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== طباعة السجل الحالي Private Sub PrintRecBtn_Click() On Error GoTo Err_PrintRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.PrintOut acSelection Exit_PrintRecBtn_Click: Exit Sub Err_PrintRecBtn_Click: MsgBox Err.Description Resume Exit_PrintRecBtn_Click End Sub '===================================== التراجع عن التسجيل Private Sub UndoRecBtn_Click() On Error GoTo Err_UndoRecBtn_Click DoCmd.RunCommand acCmdUndo Exit_UndoRecBtn_Click: Exit Sub Err_UndoRecBtn_Click: MsgBox Err.Description Resume Exit_UndoRecBtn_Click End Sub '===================================== فتح التقرير وطباعة السجل المحدد بدلالة الرقم التسلسلي Private Sub Print_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport, , "ID =" & Me.ID DoCmd.RunCommand acCmdPrintPreview DoCmd.RunCommand acCmdPrint Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: If Err.Number = 2501 Then Resume Exit_OpenReportBtn_Click 'print cancelled MsgBox Err.Number & vbCr & Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== طباعة تقرير Private Sub PrintReportBtn_Click() On Error GoTo Err_PrintReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acNormal Exit_PrintReportBtn_Click: Exit Sub Err_PrintReportBtn_Click: MsgBox Err.Description Resume Exit_PrintReportBtn_Click End Sub '===================================== معاينة تقرير Private Sub VeiwReportBtn_Click() On Error GoTo Err_VeiwReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acPreview Exit_VeiwReportBtn_Click: Exit Sub Err_VeiwReportBtn_Click: MsgBox Err.Description Resume Exit_VeiwReportBtn_Click End Sub '===================================== فتح تقرير Private Sub OpenReportBtn_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: MsgBox Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== حفظ تقرير بصيغة Private Sub SendReportToBtn_Click() On Error GoTo Err_SendReportToBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OutputTo acReport, stDocName Exit_SendReportToBtn_Click: Exit Sub Err_SendReportToBtn_Click: MsgBox Err.Description Resume Exit_SendReportToBtn_Click End Sub