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

بالاذن من الاستاذ Lionheart بنفس الطريقة Sub test1() Dim a Dim r As Range Dim frA Dim x& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("ÇáÌÏæá") Set r = Range("B:B").Find("ÇáÑÞã", , , , 1) frA = r.Address If Not r Is Nothing Then Do r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 Set r = .Range("B:B").FindNext(r) Loop Until frA = r.Address End If End With End Sub وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت Sub test2() Dim a Dim r As Range Dim frA Dim x&, i&, ii& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("الجدول") For i = 1 To UBound(a) Step 10 .Cells(4 + ii * 20, 2).Select .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 ii = ii + 1 Next End With End Sub المرفق مع الخيارين sabah.xlsm

Try this code Sub Test() Const NROWS As Long = 10 Dim a, ws As Worksheet, sh As Worksheet, r As Range, s As String, m As Long, i As Long With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With s = Join(Array(Chr(199), Chr(225), Chr(209), Chr(222), Chr(227)), Empty) m = 2 Set r = sh.Columns(2) a = FindNext(s, r) If Not IsEmpty(a) Then For i = LBound(a) To UBound(a) With sh.Range("A" & a(i)).CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With sh.Range("A" & a(i) + 1).Resize(NROWS).Value = Evaluate("ROW(1:" & NROWS & ")") sh.Range("B" & a(i) + 1).Resize(NROWS).Value = ws.Range("A" & m).Resize(NROWS).Value m = m + NROWS Next i End If End Sub Function FindNext(ByVal strFind As String, ByVal rng As Range) Dim arr(), myRng As Range, iRow As Long, k As Long With rng Set myRng = .Find(What:=strFind, After:=rng.Cells(rng.Cells.Count), LookIn:=xlValues, LookAt:=xlPart) If Not myRng Is Nothing Then iRow = myRng.Row Do k = k + 1 ReDim Preserve arr(1 To k) arr(k) = myRng.Row Set myRng = .FindNext(myRng) Loop Until myRng.Row = iRow End If End With FindNext = arr End Function Note the following The code will find the rows that has the string `NUMBER` then to copy 10 numbers from the first worksheet and so on But the code is limited to the headers in the second worksheet so not all the numbers in the first worksheet will be copied

تفضل اخونا سامر تطبيق احترافي لفكرة الحضور والانصراف واحتساب الوقت .. عربون صداقة samer2.accdb

طيب على قولك ان اول رقمين لليسار ارقام العمارات ؟ معناها ان غلب لشقق ارقامها 00 على العموم اذا تريد اظهار الرقمين على اليمين ..استخدم Mid([flatNo];2;2) لكن كيف ستظهر الشقق التي لم تسكن ؟

لا تحتوي الاستعلامات على خاصية Pop-Up. يجب أن تتعامل مع البيانات عبر النماذج وليس الاستعلامات. اعمل نموذج يكون مصدره الاستعلام

وعليكم السلام ورحمه الله وبركاته تفضل 2017-Final.xlsb

لا تسجل وقت الحضور او الانصراف بالساعات والدقائق استخدم التاريخ الكامل (جنرال ) = NOW()

اخي الكريم @TQTHAMI تم التجريب على كلا نسختي ويندوز 32 و 64 بت و المكتبة تعمل بشكل سليم اعتقد انك تضع المكتبة في المسار الخاطئ المجلد interop يتم نسخه الى المسار C:\Windows وليس الى المسار C:\Windows\system32

ارفعه على ميديا في وارسل اللينك .

وعليكم السلام ورحمة الله وبركاته 🙂 أنا تعلمت أساسيات الأكسس من قناة الأستاذ المهندس منذر السفان .. https://www.youtube.com/watch?v=I5B2G1At_lA&list=PLof3yw6ZFPFgJ64ioThh8IR_X9Rc6i0Zk

جرب هذا الحل للاستاذ الكبير الخبير ابراهيم الحداد السلام عليكم ورحمة الله ضع هذه الدالة " PtrSafe " بين كلمتى "Declare" و "Function" فى كل سطر تجد فيه هاتين الكلمتين

مبدع،،، الله يوفقك،، Showbox jiofi.local.html tplinklogin

مشاركة مع الخبير @kanory مجرد افكار لا اكثر نمارس هواية البرمجة مع بعض التأملات خذ بعض الافكار الي اضفتها لبرنامجك - اضفت لك جدول و في داخله كلمة مرور - عشان تعرض السطور المخفية راح يطلب منك كلمة مرور طبعا هي نفسها الي في الجدول 1234 بسيطة جدا اشكرا على المتابعة - تقدر تحتفظ باختيارك في عرض الصفوف و اخفائها للمرة القادة في زيارتك الميمونة - خطاباتك اذا برنامج ما حصل الخطاب في الفولدر راح يعطيك رسالة تنبيه رايقة جدا بدون تخويف اتمنى تعجبك الفكرة مجرة افكار خلال لحظات تأمل و اشكرك و اشكر كل من قرأ بتأمل و اعطاني وقته الثمين برنامج متابعة.zip

لم افهم عليك بالنسبة للطلب الاول .... اذا تم اخفائها فيتم اخفائها في النموذج الرئيسي والفرعي معا ..... وعند الاظهار يظهرها جميعا دفعة واحد ... هل هذا هو المطلوب ؟؟؟؟؟ اما المطلوب الثاني .... فستخدم هذا الكود .... Dim X$ Dim dirr As String Dim i As String i = Nz(Me.k_code, 0) dirr = CurrentProject.Path & "\files\" & i & ".tif" X$ = Dir$(dirr) If X$ = "" Then MsgBox "It does Not exist!", vbExclamation, "Doesn't Exist" Else ShellExecute Me.hwnd, "open", dirr, "", "", 1 End If

طالما ان النموذج يفتح لاسم الشخص ..فلماذا تعملين 3 نماذج ؟ على كل حال ...جربي المرفق Database1.rar

الأخ الفاضل MSG السلام عليكم أتمنى من الله أن يكون مساعدتي هذه غير مخالفة ولا تمس حقوق الملكية الخاصة بملف الـPDF جدول النوافذ والابواب الموقع العام.docx جدول النوافذ والابواب الموقع العام.xlsx

السلام عليكم اتفضل استاذ رامى ولكن وضح كيف تريد الفاصله وضح اكثر تحياتى

السلام عليكم الشكر موصول للأخ سليم حاصبيا للإفادة هذا حل عن طريق الاكواد Sub test() Dim sh As Worksheet: Set sh = Feuil4 Dim Lr As Long: Lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row - 1 Dim i As Integer, r As Integer, x As Integer, xx As Integer For i = 2 To Lr x = Val(sh.Range("A" & i + 1)) - Val(sh.Range("A" & i)) Select Case x Case Is > 1 For xx = 2 To x r = r + 1 sh.Range("O" & r).Value = Val(sh.Range("A" & i)) + xx - 1 Next End Select Next End Sub تحياتي للجميع

بارك الله فيك استاذ اشرف