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

لأنك لم تطلب وتوضح ذلك test2024.xlsb

السلام عليكم الاول : لإلغاء رسائل التحذير التي تظهر عند تشغيل الاستعلام الثاني : لتفعيلها وارجاع المياه الى مجاريها .. لآنه تم تشغيل الاستعلام بصمت

اعتذر منك ...لم افهم السؤال ..وربما هذا بسبب العمر 😂 وشكرا لاستاذي الحبيب @kanory الذي افهمني بجوابه عن ماهية السؤال

تفضل نسبة التحصيل العلمي للطلاب.xlsb

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

وعليكم السلام ورحمه الله اتفضل راجع الموضوعات ادناه الموضعات ادناه

تفضل =SUM(B2*360;C2*30;D2)

اخي واستاذي الغالي @Eng.Qassim وما انا عنك ببعيد ... نسأل الله حسن الختام

تفضل البيض.xlsx

جرب كده .............. عند حدث الفتح ... DoCmd.SetOrderBy "datet, fonction, name ASC"

وعليكم السلام عملت لك مربع نص للتصفية حسب الاسم او الوظيفة BASE2024.rar

وعليكم السلام ورحمة الله وبركاته تفضل test2024.xlsb

😂 انا متأسفت ...توهمت في الملف ashraf .rar

تفضل نسبة التحصيل العلمي للطلاب.xlsb

تفضل هذا المثال و اي استفسار ستجدني و الاخوة في الخدمة فقط قم بفك الضغط عن الملف و من ثم التجربة مثال ربط الاكسل.zip

علما بان الاكسس مهيأ لفعل ماتريد لكن هل ممكن مثال لما تريد بالضبط مع شرح ومرفق للتطبيق عليه حتى يسهل فهم طلبك بارك الله فيك

لقد وضعت ملفاً بهذا الموضوع قبل ان ترفع مثالك ارجو ان يكون المطلوب الكود Option Explicit Sub Copy_By_Choise() Rem Created By Salim Hasbays On 1/3/2020 Application.ScreenUpdating = False On Error GoTo End_Me Dim S As Worksheet, T As Worksheet Dim i%, col%, X%, Last%, m%, k%, Howmay_row% Dim Title_arr Set S = Sheets("Source"): Set T = Sheets("Target") col = T.Cells(2, Columns.Count).End(1).Column If col = 1 Then col = 500 Howmay_row = S.Range("G2") Title_arr = Application.Transpose(S.Range("a1:d1")) Title_arr = Application.Transpose(Title_arr) Last = S.Cells(Rows.Count, 2).End(3).Row T.Range("A2").Resize(Last, col).Clear m = 3: k = 1 For i = 2 To Last For X = 0 To 3 T.Cells(m, k).Offset(, X) = _ S.Cells(i, 1).Offset(, X) Next X m = m + 1 If m Mod (Howmay_row + 3) = 0 Then m = 3: k = k + 5 Next i col = T.Cells(3, Columns.Count).End(1).Column For k = 1 To col Step 5 Cells(2, k).Resize(, 4) = Title_arr With T.Range("B2").Offset(, k - 1).CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With Next Erase Title_arr: Set S = Nothing: Set T = Nothing End_Me: Application.ScreenUpdating = True End Sub الملف مرفق Split_table.xlsm

كود رائع لكن من الافضل تقصير الحلقات التكرارية (لا داعي لتشغيلها حتى الصف رقم 1000 منها 995 صف فارغ) ما ادرانا عدد الصفوف ربما اكثر من 1000 أو اقل لماذا لا نجعل اكسل وحده يحدد عدد الصفوف (10 15 .... 100 ... 1000 الخ.) اقترح هذا الكود Sub rangeToColumn() Dim i%, m% i = 2: m = 2 Range("c2").Resize((Range("a2").CurrentRegion.Rows.Count) * 3) _ .ClearContents Do Until Range("a" & i) = vbNullString With Cells(m, 3) .Value = Range("A" & i) .Offset(1) = Range("B" & i) End With m = m + 2 i = i + 1 Loop End Sub

العذر مقبول اليك الملف Creasy_data_val_1.xlsx

تم التعديل على الماكرو Private Sub CommandButton1_Click() Dim Final_row As Long, k% Final_row = Cells(Rows.Count, 1).End(3).row + 1 For k = 1 To 5 Cells(Final_row, 1).Offset(, k - 1) = Me.Controls("TextBox" & k) Next On Error GoTo EXIT_ME Cells(Final_row, 1) = CInt(Cells(Final_row, 1)) colorize_me For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next Exit Sub EXIT_ME: MsgBox "YOU MUST ENTER A NUMBER>0" Cells(Final_row, 1).Resize(, 5).ClearContents For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next End Sub '++++++++++++++++++++++++++++++++++++++ Sub colorize_me() Dim laste_row As Long, I As Long laste_row = Cells(Rows.Count, 1).End(3).row Range("A8").Resize(laste_row - 7, 5).Interior.ColorIndex = xlNon myvalu = "=SUMPRODUCT(--(A8" & "&" & """*""" & "&" & _ "B8=$A$8:A" & 8 & "&" & """*""" & "&" & "B$8:B" & 8 & "))" Range("MM8").Resize(laste_row - 7).Formula = myvalu For I = 8 To laste_row If Range("MM" & I) > 1 Then Range("A" & I).Resize(, 5).Interior.ColorIndex = 6 MsgBox "Duplicate: " & Chr(10) & Range("MM" & I) - 1 & IIf(Range("MM" & I) = 2, "Time", "Times") End If Next Range("MM8").Resize(laste_row - 7).Clear End Sub الملف من جديد SALIM_code_UPDATED.xlsm

تم معالجة الامر Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Range("B8:M8").ClearContents Range("B4:M4").ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D6"), Lookat:=1) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row With Me.Range("B8") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(, 11) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row + 1 Set Source_rg = Me.Range("a12:M" & lra) If Me.Range("d2") = "" Then MsgBox "NO data to Enter": Exit Sub Set Find_rg = Source_rg.Find(Me.Range("d2"), Lookat:=1) If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub Range("B4:M4").Copy Cells(lra, 2).PasteSpecial (xlPasteValues) Application.CutCopyMode = False: Me.Range("d2").Select End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D2"), Lookat:=1) If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub Range("B4:M4").Copy Cells(lra + 1, 2).PasteSpecial (xlPasteValues) Application.CutCopyMode = False: Me.Range("d2").Select End Sub T-2019_Salim_UPDATE.xlsm

تعديل بسيط على هذا السطر في الكود Range("E" & i).Resize(, UBound(My_Arr)) = My_Arr ليصبح هكذا (زيادة واحد فقط) Range("E" & i).Resize(, UBound(My_Arr) + 1) = My_Arr

جرب هذا الماكرو دوال الاكسل لا يمكنها تغيير النتسيقات( انها تنظر فقط الى محتوى الخلايا ولا يهمها الخطوط في الخلية ولا اذا كانت مدمجة أو لا) Option Explicit Sub test() Application.ScreenUpdating = False Range("B8").CurrentRegion.Clear Range("B2").CurrentRegion.Copy Range("B8") Range("B8").CurrentRegion.UnMerge Range("C10").Cut Range("C9") Range("B10:d10").Clear Application.ScreenUpdating = True End Sub الملف مرفق Small_example.xlsm

رائع استاذ علي ومعادلات رائعة ايضاً لكن اسمح لي ان اضيف كود لهذا الغرض لعل فيه افادة لمن يريد التعمق اكثر في عالم الــ Diuctionary من خلال الــــ VBA Option Explicit Sub Get_Phone() Rem ====>> Created By Salim Hasbaya On 18/7/2019 Application.ScreenUpdating = False Dim Dict As Object Dim Salim As Worksheet Dim Itm, K, i%: i = 2 Dim My_Arr, M_key Set Dict = CreateObject("Scripting.Dictionary") Set Salim = Sheets("Salim") With Salim .Range("D2").CurrentRegion.Offset(1) _ .Resize(, 10).ClearContents i = 2 Do Until .Range("A" & i) = vbNullString K = .Range("A" & i): Itm = .Range("B" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & ";" & Itm End If i = i + 1 Loop '======================================== i = 2 With Dict For Each M_key In .keys Range("D" & i) = M_key My_Arr = Split(.Item(M_key), ";") If UBound(My_Arr) = 0 Then Range("E" & i) = .Item(M_key) Else Range("E" & i).Resize(, UBound(My_Arr)) = My_Arr End If i = i + 1 Next End With '======================== .Range("D2").CurrentRegion.Value = _ .Range("D2").CurrentRegion.Value End With Dict.RemoveAll: Set Dict = Nothing Salim.Columns("E:H").AutoFit Application.ScreenUpdating = True End Sub الملف مرفق FIND_PHONE.xlsm

وعليكم السلام -اهلا بك في المنتدى بالتأكيد لا يمكن عمل هذا بمعادلة Vlookup - ولكن يمكن بمعادلات المصفوفة كما بالملف وتم عمل اكثر من المطلوب شوف بنفسك ايجاد كل القيم التى تخص رقم معين.xlsx

لا حاجة للمعادلات في هذا املف الـــ Vba يقوم بكل ما يناسب الملف مرفق مع الشرح الكودات اللازمة Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("b8:l8"), Range("c9:l9")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d6")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("d6")).Row With Me.Range("b8") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d2")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row With Me.Range("b4") Cells(r, 2) = .Value: Cells(r, 3) = .Offset(, 1): Cells(r, 4) = .Offset(, 2) Cells(r, 5) = .Offset(, 3): Cells(r, 6) = .Offset(, 4): Cells(r, 7) = .Offset(, 5) Cells(r, 8) = .Offset(, 6): Cells(r, 9) = .Offset(, 7): Cells(r, 10) = .Offset(, 8) Cells(r, 11) = .Offset(, 9): Cells(r, 12) = .Offset(, 10): Cells(r, 13) = .Offset(1, 1) End With End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("B4:L4"), Range("C5:L5")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("D2")) If Find_rg Is Nothing Then MsgBox "This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("D2")).Row With Me.Range("b4") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub T-2019_Salim.xlsm

بعد اذن الاساتذة الكرام هذا الماكرو Option Explicit Sub get_data() Dim B As Worksheet: Set B = Sheets("BASMMA") Dim N As Worksheet: Set N = Sheets("NASHER") Dim Dic As New Dictionary Dim i%: i = 2 Dim x With N Do Until .Range("B" & i) = vbNullString If Not Dic.Exists(.Range("B" & i).Value) Then Dic.Add .Range("B" & i).Value, .Range("F" & i).Resize(, 59).Value End If i = i + 1 Loop B.OLEObjects("Combobox1").Object.List = Dic.Keys End With x = N.Range("B:b").Find(B.Range("h2")).Row With B .Range("a2") = N.Cells(x, 1) .Range("b2") = N.Cells(x, 2) .Range("c2") = N.Cells(x, 4) .Range("e2").Resize(59, 1).Value = _ Application.Transpose(Dic.Items(x - 2)) End With Dic.RemoveAll End Sub الملف مرفق Salim_Search.xlsm

بسم الله الرحمن الرحيم يستعمل هذا البرنامج في معرفة الكود المستعمل في البرنامج و المحافظة على البرنامج الأصلي أي لايكون هناك لعب و اللامبالات بالبرنامج الذي كسرت حمايته و يبقى لصاحبه ملاحظة : لكل مستعمل أخذ هذا الأخير من الناحية التعليمية فقط الرقيب الأعلى هو اللــــــــــــــــــــــــــــــــــه أضغط هنا أو هــــــــنا