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

إن شاء اللّه يفيدك هذا المرفق بيان العجز والزيادة.xlsx

الله كريم اخي @alzahrani07وعلى قول عادل امام .. انا كبرت في دماغي 😂 تفضل حسب طلبك بعد بحث واستقصاء Serch_Database1 - Copy.accdb

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

@أ / محمد صالح @lionheart اتقدم بخالص الشكر والتقدير لشخصكم الكريم دمتم فى خير ونفعنا الله بعلمك وجعله في ميزان حسناتكم

أخي الكريم بالنسبة لموضوع الاستعداد للكتابة فتحديد الخلية المشار إليها سابقا مني تكفي وبالنسبة لموضوع setfocus أو focus فهذه تستخدم مع عناصر التحكم في النموذج وليس مع الخلايا في الشيت

اليك التعديل بمعيار ID Serch_Database1.accdb

Try this version for earlier versions of office Sub Test() Dim a, x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Range("A4:N" & Rows.Count) .ClearContents: .Cells.UnMerge: .Borders.Value = 0 End With With ws.[A5].CurrentRegion Set r = .Offset(, .Columns.Count + 2).Range("A1:A2") a = Application.Transpose(.Columns(5).Offset(1).Value) With Application x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False)) End With For Each e In x If e <> "" Then r(2).Formula = "=E6=""" & e & """" m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row m = IIf(m <= 5, 4, m) With sh.Range("A" & m) .Value = e .Resize(1, 14).Merge .HorizontalAlignment = xlCenter End With .AdvancedFilter 2, r, sh.Range("A" & m + 1) End If Next e r.ClearContents End With Application.ScreenUpdating = True End Sub

شكرا جزيلا استاذ محمد صالح lionheart شكرا جزيلا لحضرتك

Sub Test() Dim ws As Worksheet For Each ws In Worksheets ws.Visible = ws.Name = "Maine" Next ws End Sub

وهذه محاولة ارجو ان يكون هو المطلوب mySQL = "Select * From tblData ORDER BY ID" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst For i = 1 To Int(rst.RecordCount / 5) Me.List1.AddItem rst!CustCode rst.MoveNext Next For i = (List1.ListCount + 1) To (List1.ListCount + Int(rst.RecordCount / 5)) Me.List2.AddItem rst!CustCode rst.MoveNext Next For i = (List2.ListCount + 1) To (List2.ListCount + Int(rst.RecordCount / 5)) Me.List3.AddItem rst!CustCode rst.MoveNext Next For i = (List3.ListCount + 1) To (List3.ListCount + Int(rst.RecordCount / 5)) Me.List4.AddItem rst!CustCode rst.MoveNext Next For i = (List4.ListCount + 1) To (List4.ListCount + rst.RecordCount / 5) Me.List5.AddItem rst!CustCode rst.MoveNext Next rst.Close Test77.rar تحياتي

تفضل هذا التعديل open.zip

بالتوفيق يارب

I completely agree with Mr. Mohamed Just select is enough or you can use Application.GoTo Range("A1"), True

Sub Test() Dim a, x, ws As Worksheet, sh As Worksheet, r As Range Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) Set r = ws.Range("C2:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) a = Application.Transpose(r.Value) With Application x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False)) End With sh.Range("B2:B" & Rows.Count).ClearContents sh.Range("B2").Resize(UBound(x)).Value = Application.Transpose(x) End Sub

جزاكم الله عنا خيرا ونفعنا وامتعنا بعلمكم الغزير وجعله فى ميزان حسناتكم

Sub Test() Dim r As Range Set r = Range("A1") r.Select SendKeys "{F2}", True DoEvents SendKeys "{LEFT " & CStr(Len(r.Value)) & "}", True DoEvents End Sub

Press Alt + F11 to open VBE editor > from Insert menu > Select Module > Paste the code I posted To run the code, press F5 when in VBE editor or go back to the worksheet and press Alt + F8 then select the macro name and finally click Run

الموضوع ممكن باستخدام دوال الويندوز لكن إذا سمحت لي ما الفائدة العملية من إجراء مثل هذا؟ نقل مؤشر الفارة فوق خلية معينة

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

Sub Test() Dim a, i As Long, ii As Long, t As Long a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2).Value a(1, 2) = a(1, 2) & " 1" With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a, 1) If Not .Exists(a(i, 1)) Then .Item(a(i, 1)) = Array(.Count + 2, 2) For ii = 1 To 2 a(.Count + 1, ii) = a(i, ii) Next ii Else t = .Item(a(i, 1))(1) + 1 If UBound(a, 2) < t Then ReDim Preserve a(1 To UBound(a, 1), 1 To t) a(1, t) = Replace(a(1, 2), "1", t - 1) End If a(.Item(a(i, 1))(0), t) = a(i, 2) .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t) End If Next i t = .Count + 1 End With With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2)) .CurrentRegion.Clear .Value = a: .Borders.Weight = 2 .HorizontalAlignment = xlCenter .Columns.AutoFit .Parent.Select End With End Sub

جزاك الله الف خير ... مشكور اخي جعلها الله في ميزان حسناتك

جميعا بإذنه تعالى

جزاكم الله خيرا أستاذ محمد صالح وبارك الله لنا فى عمركم ونفعنا بعلمكم وغفر الله لنا ولكم اللهم أمين يارب العالمين والله فى عون العبد ما دام العبد فى عون أخيه أعانكم الله وآواكم الله وآنسكم الله بقربه

Sheet1.Range("H" & Sheet1.Cells(Rows.Count, "H").End(xlUp).Row).PasteSpecial

I could save to PDF without any problems in the PDF output. May be you have to change the virtual printer that you use

First correct the combobox name from [Calss] to [Class] In userform module Dim ws As Worksheet, m As Long Private Sub StudentName_Enter() Dim a, i As Long, k As Long If Natija.Value <> "" And Class <> "" Then a = ws.Range("A2:D" & m).Value ReDim b(1 To UBound(a, 1)) For i = LBound(a) To UBound(a) If Val(a(i, 3)) = Val(Class.Value) And a(i, 4) = Natija.Value Then k = k + 1 b(k) = a(i, 2) End If Next i If k > 0 Then ReDim Preserve b(1 To k): StudentName.List = b End If End Sub Private Sub UserForm_Initialize() Dim a Set ws = Worksheets("Sheet1") m = ws.Cells(Rows.Count, "B").End(xlUp).Row a = GetDistinct(ws.Range("D2:D" & m)) Natija.List = a a = GetDistinct(ws.Range("C2:C" & m)) Class.List = a End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim vArr, v, dic As Object Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function

تفضل تم إجراء تعديلين المدى الذي يتم مسحه والعمود F وما بعده بالتوفيق Search++ - Copy.xlsm

After this line Cells(R + 6, "F").Value = .Cells(i, "H").Value Add this line Cells(R + 6, "G").Resize(1, 4).Value = .Cells(i, "I").Resize(1, 4).Value

thank you so much 👌

إن شاء اللّه يفيدك هذا الكود Sub mas() Application.ScreenUpdating = 0 Dim lr1 As Long, lr2 As Long, r As Long, c As Long, n As Long lr1 = Sheet1.Cells(Rows.Count, 1).End(3).Row lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row Sheet2.Rows("4:" & IIf(lr2 < 4, 4, lr2)).Delete Shift:=xlUp For r = 6 To lr1 c = 0 Sheet1.Select lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row If Evaluate("=COUNTIF($E$6:E" & r & ",E" & r & ")") = 1 Then Sheet1.Range("A5:N5").Copy Sheet2.Select Sheet2.Range("A" & lr2 + 2).Select ActiveSheet.Paste Application.CutCopyMode = False Sheet2.Range("f" & lr2 + 1) = Sheet1.Range("e" & r) Sheet2.Range("a" & lr2 + 2) = c + 1 Sheet2.Range("b" & lr2 + 2 & ":N" & lr2 + 2).Value = Sheet1.Range("b" & r & ":N" & r).Value c = c + 1 For n = r + 1 To lr1 If Sheet1.Range("e" & n) = Sheet1.Range("e" & r) Then lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row Sheet2.Range("A" & lr2 & ":N" & lr2).Copy Range("A" & lr2 + 1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False Sheet2.Range("a" & lr2 + 1) = c + 1 Sheet2.Range("b" & lr2 + 1 & ":N" & lr2 + 1).Value = Sheet1.Range("b" & n & ":N" & n).Value c = c + 1: Sheet2.Range("A4").Select End If Next n End If Next r Sheet2.Select Application.ScreenUpdating = 1 MsgBox "Done by mr-mas.com" End Sub وهذا ملفك بعد التعديل بالتوفيق الترحيل على حسب الوظيفة.xlsm

Sub Test() Dim x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Range("A4:N" & Rows.Count) .ClearContents: .Cells.UnMerge: .Borders.Value = 0 End With With ws.[A5].CurrentRegion Set r = .Offset(, .Columns.Count + 2).Range("A1:A2") x = .Parent.Evaluate("TRANSPOSE(UNIQUE(" & .Columns(5).Offset(1).Address & "))") For Each e In x If e <> "" Then r(2).Formula = "=E6=""" & e & """" m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row m = IIf(m <= 5, 4, m) With sh.Range("A" & m) .Value = e .Resize(1, 14).Merge .HorizontalAlignment = xlCenter End With .AdvancedFilter 2, r, sh.Range("A" & m + 1) End If Next e r.ClearContents End With Application.ScreenUpdating = True End Sub

There are no events for the check boxes on form controls, but there is a workaround In standard module put the code Sub CheckBoxFormControl() Dim ws As Worksheet, cb As Shape, sChk As String, r As Long, c As Long Set ws = ActiveSheet With ws.CheckBoxes(Application.Caller) sChk = .Name r = .TopLeftCell.Row c = .TopLeftCell.Column End With If ws.CheckBoxes(Application.Caller).Value = 1 Then For Each cb In ws.Shapes If cb.Type = msoFormControl Then If cb.FormControlType = xlCheckBox And cb.Name <> sChk Then If cb.TopLeftCell.Row = r And cb.TopLeftCell.Column = c Then If cb.ControlFormat.Value = 1 Then cb.ControlFormat.Value = -4146 End If End If End If Next cb End If End Sub Now select only one check box then press Ctrl + A to select all the check boxes on the worksheet then right click and assign macro [CheckBoxFormControl] The code will loop through each check box in the same row only and uncheck any other check boxes except the one triggered by Application.Caller

Th example you posted is the same result when I entered the day 16 in the inputbox Can you explain what's the wrong exactly

وعليكم السلام ورحمة الله وبركاته بالاضافة الى ما تفضل به استاذنا الفاضل @Eng.Qassim وله جزيل الشكر تفضل اخي الكريم DoCmd.OpenForm "Employees", , , "ID=" & Me.Text1.Value Sample.rar تحياتي

فكرة بره الصندوق على اعتبار ان مصدر البيانات ثابت من 1 الى 35 Test.accdb

Private Sub Workbook_Open() If Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("D:").SerialNumber) <> "F8BCE74D" Then MsgBox "Message 1" ThisWorkbook.Close True End If If Date >= DateValue("12/12/2021") Or Sheets("Sheet2").Range("A48") = "mosaad" Then MsgBox "Expired", vbExclamation If InputBox("Enter Password") <> "123" Then Sheets("Sheet2").Range("A48") = "AA" MsgBox " Message 2 " ThisWorkbook.Save Application.Quit End If End If End Sub

تفضل حسب طلبك Dim i As Integer i = DCount("CheckNumber", "CheckDataCustomer", "CheckNumber='" & Me.CheckNumber & "'") If i > 0 Then MsgBox " السجل مكرر ", , " تنبيه" Me.CheckNumber = "" Exit Sub End If Database4.rar

السلام عليكم أخي العزيز لعلني لم استوعب المطلوب بشكل جيد ولكن إن شاء الله من خلال ملاحظاتكم ومراجعة الجدول سيتم تدارك الأخطاء وتصحيحها بالنسبة لطلبكم الأخير تم التعديل في معادالة الزيادة فقط و إن شاء الله تكون مضبوطة بيان العجز والزيادة للعام 2021 (1).xlsx

تلبية لطلب الاخ حمادة عمر و لاثراء المنتدى والاهم للافادة فقد قمت بتعريب برنامج الموردون الدي طرحته سابقا كما طلب مني الاخ حمادة ارجو ان ينال اعجابكم .... لانطلب منكم سوى الدعاءلانطلب منكم سوى الدعاء برنامج الموردون نسخة عربية.xlsm

بسم الله الرحمن الرحيم لا أعلم إن كان أحد سبقني بهذه التهنئة أم لا ولكن والله فرحت جدا عندما رأيت صورة Most Valuable Professional أسفل اسم أخي وصديقي محمد طاهر مدير المنتدى وأقول له 10000000000000000000000000000000000000000000 مبروك تستحقها

يا ريت مزيد من المعلومات حيث أنها شهادة عالمية أيضا شكرا لك

شكرا لك أخي يحيى وهذا رابط مباشر بدون دخول موقع ميكرو سوفت هنــــــــــــــــــا وهذا سيريال التفعيل MPTGX-FY23H-HHDK9-XQDB4-3TDF9

أخي الكريم خالد يوجد بعض الاستفسارات وبإذن الله ستجد ما يسرك بالنسبة لبرنامج الأوت لوك هل يستخدمه مستخدم واحد (حضرتك) أم يوجد أكثر من حساب؟ هل اسم الملف بصيغة pdf هو نفس رقم تليفون العميل؟ بالنسبة لخامسا وسادسا أظن أنها بعيدة عن الموضوع إلا إذا كنت تريد قراءة الرقم الذي يقومون بكتابته في رسالتهم لك وتضعه في ملف إكسل (((وهذا موااااااااال آخر) بانتظار توضيحك وبعون الله ستجد ما يسرك

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

تفضل أخي الكريم جلال الحل بنفس طريقة الأخ خبور خير وأعتقد أنها سهلة الوصول إليها من عضو فعال مثلك أخي الكريم mas-counts.rar

مفيش مشكلة أخي الكريم المهم الوصول للمطلوب

بعد إضافة الكود فين؟؟ وهل الكود بالملف المرفق يظهر هذه الأخطاء؟؟ برجاء مزيد من التوضيح

اقصد سهم مؤشر الفأرة إلى خليه يتم تحديدها فى الكود