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

جرب هذا الكود ، ولاحظ ما عندنا me.refresh : Private Sub Form_Timer() On Error GoTo err_Form_Timer Me.[امع1].Form.Requery Me.[امع2].Form.Requery Me.[امع3].Form.Requery Me.[امع4].Form.Requery Me.[امع5].Form.Requery Me.[امع6].Form.Requery Exit_Form_Timer: Exit Sub err_Form_Timer: If Err.Number = 1 Then 'Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_Form_Timer End Sub جعفر

تم تعديل الكود في المشاركه السابقه

السلام عليكم المعادلة التي أرفقتها مع الملف باستعمال الدالة VLOOKUP تعمل بشكل جيد وتفي الغرض المطلوب!!

الموضوع بسيط جدا أخي ... فقط من خصائص القائمة المنسدلة > بيانات > إلتزم بالقائمة > نعم . مرفق لك التعديل : Database4.accdb

السلام عليكم ورحمة الله جرب المرفق مع بعض التعديلات... ملاحظة: يجب أن يكون رقم التسلسل في ورقة "البيانات" بالعمود A في السطر الأول من جدول كل عميل (كما فعلتُ للأرقام الأرقام 1، 2، 3، 4)... التسويات.xlsm

وعليكم السلام ورحمة الله وبركاته تفضل اخى الكريم Option Explicit Sub Test() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sFile As String Application.ScreenUpdating = False Set WS = ThisWorkbook.Worksheets("ورقة1") sFile = ThisWorkbook.Path & "\" & "العملاء.xlsm" Set WB = Workbooks.Open(sFile, False) For Each SH In WB.Worksheets If SH.Name = WS.Cells(2, 3).Value Then WS.Cells(3, 3).Value = SH.Range("H2").Value Next SH WB.Close SaveChanges:=True Application.ScreenUpdating = True End Sub

تفضل اخي الكريم db1.rar تحياتي

وعليكم السلام ورحمة الله وبركاته ضع هذا الكود في ملفك وشغله ستجد ملف باسم ملف REEL_DATA_OF_NOVEMBER_2021.Xlsb بجوار ملفك Sub Total() Dim ws As Worksheet, temp As Variant, arr As Variant, F As Boolean, lr As Long Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Total" And ws.Name <> "SUMMARY" And ws.Name <> "TIME" And ws.Name <> "HOLD" Then temp = ws.Range("A6:S" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value2 If F Then Dim I As Long, ii As Long, ub As Long ub = UBound(arr, 1) arr = Application.Transpose(arr) ReDim Preserve arr(1 To UBound(arr, 1), 1 To ub + UBound(temp, 1)) arr = Application.Transpose(arr) For I = LBound(temp, 1) To UBound(temp, 1) For ii = 1 To UBound(temp, 2) arr(ub + I, ii) = temp(I, ii) Next ii Next I Else arr = temp F = True End If End If Next ws If Not Evaluate("isref('" & "Total" & "'!A1)") Then Sheets.Add.Name = "Total" With Sheets("Total") .Range("A2:S65536").ClearContents .Range("A1").Resize(1, 19).Value = Array("V", "HH", "J", "K", "L", "DD", "HH", "K", "L", "P", _ "GG", "S", "DF", "GH", "HJ", "KJ", "FGH", "G", "Remarks") .Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr With .Range("A1:S" & .Cells(Rows.Count, 2).End(xlUp).Row) .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .RowHeight = 15 ActiveWindow.Zoom = 75 .EntireColumn.AutoFit .Borders.Value = 1 End With End With ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "REEL_DATA_OF_NOVEMBER_2021", FileFormat:=xlExcel12 Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True End Sub

جرب هذا لعله يفيد DoCmd.Echo False me.Refresh DoCmd.Echo True

تفضل هذا التعديل البرنامج.zip

لك جزيل الشكر و التقدير اخ عبدالله الصاري

اطلعت علي الملف 1 - اخر اسم في القائمة فيه تاريخ الدخول اكبر من الخروج فهل هذا خطا ؟ 2- كيف تعرف ان هناك تداخل ام لا ؟ ما هي القاعدة ؟

السلام عليكم اخي الفاضل ارجو ان يكون طلبك في الرابط الاتي

تفضل بطاقة.accdb

إن كان ناتج هذه المعادلة مرجع نطاق مثل A1 فيمكن استعمال هذه المعادلة =HYPERLINK("#"&CELL("address",INDIRECT("data!"&IFERROR(VLOOKUP(H11;DATA!A3:AQ252;43;FALSE);VALUE(("0"))))),"click here") ويمكن تغيير نص الرابط click here إلى أي نص مرغوب بالتوفيق

تفضل 111البرنامج.rar

تفضل اخي 111البرنامج.rar

تفضل Sub test() Dim RG1, RG2 Dim r, x Set RG1 = [D3]: Set RG2 = [E3] r = 2 Application.ScreenUpdating = False If RG1 > 51 Then MsgBox "ادخل فقط من 1 الى50", vbExclamation: Exit Sub If RG2 > 100 Then MsgBox "لا يمكن ادخال اكبر من 100", vbExclamation: Exit Sub Range("j2:j1000000").ClearContents For x = RG1 To RG2 Range("j" & r).Value = x r = r + 1 Next x Application.ScreenUpdating = True End Sub مسلسل.xlsm

اتفضل نستخدم ذلك مع الارقام' stLinkCriteria = "[PersonalNumber]=" & Me.PersonalNumber نستخدم ذلك مع النصوص' stLinkCriteria = "[PersonalName] ='" & [txtLastName] & "'" نستخدم ذلك مع التواريخ' stLinkCriteria ="[DateOfBirth] =#" & [txtDateOfBirth] & "#"

Public Sub CMDSEARCH_Click() Dim x, ws As Worksheet, i As Long, j As Long, lastRow As Long With Me.ListBox1 .Clear .ColumnCount = 7 .ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" .ColumnHeads = 0 Set ws = Sheets("Ledger") x = Application.Match(ComboBox1.Value, ws.Rows(1), 0) If Not IsError(x) Then lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row For i = 1 To lastRow If TextBox1 <> "" And InStr(ws.Cells(i, x), TextBox1) <> 0 Then .AddItem .List(j, 0) = ws.Cells(i, 1) .List(j, 1) = ws.Cells(i, 3) .List(j, 2) = ws.Cells(i, 4) .List(j, 3) = ws.Cells(i, 16) .List(j, 4) = ws.Cells(i, 17) .List(j, 5) = ws.Cells(i, 18) .List(j, 6) = ws.Cells(i, 10) j = j + 1 End If Next i End If End With End Sub

تفضل يا سيدي tartib for printing final.rar