شوقي ربيع

السلام عليكم مجرد رئي عند التعامل مع الشيت من الافضل استخدام الدول في المثال الذي ارفقته مثلا دالة SUM قايمة بالواجب وحتى عند تغير القيم كما طلبت في اخر رد تعمل اتو ماتيكايا ان كنت تريد استخدام العمليات الحسابية من خلال vba فالافضل استخدامها مع Object مثال التكسات في الفورم تحياتي

السلام عليكم الخطئ في هذا السطر If Not Intersect(Target, Range("a2") & lastColumn) Is Nothing Then يجب ان تكون هكذا If Not Intersect(Target, Range("a2:g2" & lastColumn)) Is Nothing Then

تم حل المشكل و تم استبدال المرفق في المشاركة الرئيسية

السلام عليكم هذا الكود لتعبئة الكمبوبوكس بما يناسبه Sub ListCmb(sName As String, sCmb As String) Dim MyStr, MyList, i Set MyList = CreateObject("Scripting.Dictionary") MyStr = sName & "*" For Each i In Ary If i Like MyStr Then MyList(i) = "" Next i Me(sCmb).List = MyList.keys End Sub وصيغة استدعائه تكون (مثال للكمبو الاول) ListCmb "Boitie", "ComboBox7" وهذا الكود لتعبئة السعر حسب ماتختار من الكمبو مع حساب مجموع التكسات Sub Sher(sShr As String, sText As String) Dim cc Dim n: n = 11 Me(sText).Value = "" Me.TextBox126.Value = "" MyStr = sShr & "*" For Each ii In Ary n = n + 1 If ii = sShr Then Exit For Next ii If sShr = "" Then Me(sText).Value = "" Else Me(sText).Value = ws.Cells(n, 3).Value End If For cc = 1 To 5 Me.TextBox126.Value = Val(Me.TextBox126.Value) + Val(Me("TextBox12" & cc).Value) Next End Sub وصيغة استدعائه تكون (مثال للكمبو الاول) Sher Me.ComboBox7, "TextBox121" ان شاء الله يكون المطلوب تحياتي للجميع Originale14.rar

عجبا لا يوجد اي مكتابات References تضاف هذا هو الكود الخاص بالمثال الاول Option Explicit Dim a() Dim b, c, d, e Dim ws As Worksheet Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set ws = Sheets("data") If Not Intersect([A2:A17], Target) Is Nothing And Target.Count = 1 Then e = ws.Cells(Rows.Count, 1).End(xlUp).Row a = ws.Range("A2:A" & e).Value With Me.ComboBox1 .List = a .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Visible = True .Activate .ListRows = 20 .MatchEntry = fmMatchEntryNone .TextAlign = fmTextAlignRight End With Me.ComboBox1 = Target Else Me.ComboBox1.Visible = False End If If Not Intersect([H2:H17], Target) Is Nothing And Target.Count = 1 Then UserForm1.Left = Target.Left + 150 UserForm1.Top = Target.Top + 70 - Cells(ActiveWindow.ScrollRow, 1).Top UserForm1.Show End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, a, 0)) Then Set b = CreateObject("Scripting.Dictionary") d = UCase(Me.ComboBox1) & "*" For Each c In a If UCase(c) Like d Then b(c) = "" Next c Me.ComboBox1.List = b.keys Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1 End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) e = ws.Cells(Rows.Count, 1).End(xlUp).Row Me.ComboBox1.List = ws.Range("A2:A" & e).Value Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub وهذا خاص بالمثال الثاتي اي اليوزرفورم Option Explicit Dim a() Dim b, c, d, e Private Sub Label1_Click() ActiveCell = Me.ComboBox1 Unload Me End Sub Private Sub UserForm_Initialize() Me.Caption = "http://www.officena.net" Dim ws As Worksheet: Set ws = Sheets("data") e = ws.Cells(Rows.Count, 1).End(xlUp).Row a = ws.Range("A2:A" & e).Value With Me.ComboBox1 .List = a .ListRows = 20 .MatchEntry = fmMatchEntryNone .TextAlign = fmTextAlignRight End With End Sub Private Sub ComboBox1_Change() Set b = CreateObject("Scripting.Dictionary") d = UCase(Me.ComboBox1) & "*" For Each c In a If UCase(c) Like d Then b(c) = "" Next c Me.ComboBox1.List = b.keys Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell = Me.ComboBox1: Unload Me End Sub

جرب الملف الثاني 2003

تم اضافة ملف 2003 في الموضوع الاصلي

بسم الله الرحمان الرحيم السلام عليكم اولا ما هو النص التنبئي باختصار هو تنبئ البرنامج او الدالة او الكود بالكلمات التي تبحث عنها من خلال كتابة اول حروف الكلمة مثل مايحدث اثناء البحث عن طريق محرك البحث قوقل هذا الموضوع ليس جديد فهناك كود في المنتدى يعتمد على مربع نص وليست بوكس لاكني منذ فترة حاولت تطبيق الامر على الكمبوبوكس الى ان وفقني الله الى ذلك وها انا الان اشارككم الموضوع ما هي الفائدة من هذا الموضوع كثيرا ما يكون لدينا قاعدة بيانات كبيرة مثلا الاصناف في الفواتير و غالبا متكون عمليات الادخال خاصتا مكررة و كثيرة فهذه الطريقة ستساعدك كثيرا في ادخال الاصناف بسلاسة وسهولة بدل عناء اعادت كتابت الصنف مرارا وتكرارا لا اطيل عليكم في المرفق تجد مثال توضيحي احدهما مطبق على الشيت وهو مايهم اصحاب ادخالات الفواتير والثاني مطبق على الفورم صورة توضيحية بالنسبة للمثال المطبق على الشيت كما في الصورة من جهة اليمين عند الضغط على اي خلية ملونة بالاخضر تظهر كمبوبكس اكتب داخلها اي حرف لتجلب لك الكلمات التي تحمل تلك الحرف كما في الصورة يمكنك التنقل بين النتائج بواسطة سهم الاعلى والاسفل من الكبيور اضغط انتلر لادخال النتيجة في الخلية وانتقال الكمبو الى اسفل الخلية المفعلة بالنسبة للمثال المطبق على الفورم كما في الصورة من جهة اليسار نفس الامر كما في المثال الاول فقط الاختلاف في ان ادالبحث يكون من الفورم ارجو ان يكون الموضوع مفيد للجميع تحياتي للجميع تنويه تم استبدال المرفق بعد 23 تحميل texte prédictive 2007 2003.rar

السلام عليكم الشكر موصول للاخ ابوعيد و الاخ الصقر تفضل اخي هذا الحل ان شاء الله يفي بالغرض وان يستفيد منه الجميع اولا تم برمجة كود يدرج شيت جديد باسم رمز الشركة اوتوماتيكيا في حالة زيادة عدد اسماء الشركات مع تنسيق رؤس الاعمدة كما هو في الشيت الرئيسي Sub AddWs() Dim ws As Worksheet Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ") Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row Dim sNam As String Dim i As Integer, c As Integer Dim Err For i = 2 To lrw sNam = sh.Range("A" & i).Value On Error GoTo Err Set ws = ThisWorkbook.Sheets(sNam) 0 Next Exit Sub Err: ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) ThisWorkbook.Sheets(Sheets.Count).Name = sNam Set ws = ThisWorkbook.Sheets(sNam) Application.CutCopyMode = False sh.Range("C1:S1").Copy ws.Select ws.Range("A1").Select ws.Paste Application.CutCopyMode = True Feuil1.Activate GoTo 0 End Sub ثانيا تم برمجة كود ينقل التغيرات الحاصلة في كل شركة الى الشيت الخاص بها اوتوماتيكيا ويومايا مع العلم ان البيانات تتحدث تلقائيا في حالت اي تغير في بيانات شركة ما ولا يتوقف التحديث الا في حالت تغير التاريخ في هذه الحالة يتم ادراج البيانات في قاعدة البيانات الخاصة بتلك الشركة لاكن بتاريخ مختلف ملاحظة تم برمجة الكود على اساس ان الشيت الرئيسة مرتبط باحد برامج البورصة (المضاربات) مثل مستشاري Sub Rénover() Dim ws As Worksheet Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ") Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row Dim lrw2 As Long Dim MyDat As Date Dim sNam As String Dim i As Integer, c As Integer Call AddWs For i = 2 To lrw MyDat = CDate(sh.Range("C" & i).Value) sNam = sh.Range("A" & i).Value Set ws = ThisWorkbook.Sheets(sNam) lrw2 = ws.Cells(Rows.Count, 1).End(xlUp).Row Dim Rw As Long: Rw = lrw2 + 1 If lrw2 = 1 Then ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value GoTo 1 ElseIf MyDat = CDate(ws.Range("A" & lrw2)) Then ws.Range("A" & lrw2 & ":Q" & lrw2).Value = sh.Range("C" & i & ":S" & i).Value Else ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value End If 1 Next End Sub ثالثا تم برمجة كود يقوم بملئ كمبوبكس الخاص بالرمز و اسم الشركة ايضا يعمل اتوماتيكيا Sub ListCmb() Set wsh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ") lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row Feuil1.CobName.Clear Feuil1.CobID.Clear Feuil1.CobName.List = wsh.Range("B2:B" & lLrw).Value Feuil1.CobID.List = wsh.Range("A2:A" & lLrw).Value End Sub رابعا تم برمجة كود خاص بملئ التواريخ المسجلة في قاعدة البيانات ايضا يعمل اتوماتيكا حسب اسم او رمز الشركة المختارة Sub ListCmbDate(wsNam As String) If wsNam = "" Then Exit Sub Set wsh = ThisWorkbook.Sheets(wsNam) lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row Feuil1.CmbDat1.Clear Feuil1.CmbDat2.Clear If lLrw = 2 Then Feuil1.CmbDat1.AddItem wsh.Range("A2").Value Feuil1.CmbDat2.AddItem wsh.Range("A2").Value Exit Sub Else Valeurs = wsh.Range("A2:A" & lLrw).Value Feuil1.CmbDat1.List = Valeurs Feuil1.CmbDat2.List = Valeurs End If End Sub خامسا واخير تم برمجة كود يجلب البيانات حسب اختيار المستعمل للفترة التي يريد من شيت محدث Sub RowWs(wsNam As String, MyDate1 As Date, MyDate2 As Date) If wsNam = "" Then Exit Sub CalearWs Set ws = ThisWorkbook.Sheets("ãÍÏË") Set wsh = ThisWorkbook.Sheets(wsNam) lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row Dim Rw As Long, Rw1 As Long, Rw2 As Long For i = 2 To lLrw If MyDate1 = CDate(wsh.Range("A" & i)) Then Rw1 = wsh.Range("A" & i).Row If MyDate2 = CDate(wsh.Range("A" & i)) Then Rw2 = wsh.Range("A" & i).Row: Exit For Next If Rw1 = 0 Then MsgBox "íÌÈ Çä íßæä íæã ÇáÈÏÇíÉ ÇÞá ãä Çæ íÓÇæí íæã ÇáäåÇíÉ": Exit Sub Rw = Rw2 - Rw1 + 1 ws.Range("A4").Resize(Rw, 15).Value = wsh.Range("A" & Rw1).Resize(Rw, 15).Value End Sub صورة توضيحية ملاحضة هامة الرجاء عدم التغيير في تسميات الشيتات لكي لا يتأثر عمل الاكواد (الكود يعطي خطاء) تحياتي للجميع بيانات شركة.rar

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

بسيطة فقط ضع هذا الكود في حدث الاقلاع الخاص بالفورم الذي تريد Chaouki Me مثل ما هو معملول مع الفورم Voucher

السلام عليكم على قدر فهمي لي طلبك تفضل هذا الحل الديناميكي لكي يعفيك من تكرار كتابة الاكواد لكل تاكست على حدا ويعمل على عدد غير محدود من التكسات يعني اضف ماشاءت من التكسات الى الفورم وراح يعطيك نفس النتيجة نقل بيانات بواسطة فورم واحد.rar

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

السلام عليكم لقد طلب مني في العديد من المرات فيديو يشرح تحويل ملف الاكسل الى ملف تنفيذي لذي قمت بتحميل و تعلم برنامج تصوير شرحات الفيديو (ميغلاش شيئ عن اعضاء المنتدى) هذا اول فيديو اقوم به لذى ارجو ان لاتلومني على قلت خبرتي الفكرة من تحويل ملف الاكسل الى مل تنفيذي هي انه بعد التحويل منحتاجش تفعيل الماكرو لكي تشتغل الاكود ومنه جميع اكواد الحماية التى نعرفها راح تنفع وتعمل عملها تابعو الشرح وارجو ان يكون مفهوم البرنامج المستعمل في الشرح XLtoEXE.rar تحياتي للجميع

تفضل هذا الحل ليكون الادخال ديناميكي Dim X() Dim R As Long, RR As Long Dim C As Integer Dim sText As String: sText = Me.ComboBox1.Text & " " & Me.ComboBox2.Text With ListBox1 For R = 0 To .ListCount - 1 RR = RR + 1 ReDim Preserve X(1 To 4, 1 To RR) For C = 1 To 4 If C = 2 Then X(C, RR) = sText Else X(C, RR) = .List(R, C - 1) Next Next End With ListBox1.Column = X Erase X (أستاذي القدير لم أفهم ما قصدته) الامر بسيط ان كنت تفهم المصفوفات المصفوفة عبارة عن جدول لاكن ليس في الشيت انما في ذاكرة الفيوجل ما قمت به هو اني حملت محتولى اليست بوكس الى مصفوفة دينامكية علما انه يمكنا التحكم في حجم المصفوفة الديناميكية كما نشاء .... لازمها درس طويل شاهد هذا الدرس للعلامة الاستاذ عبد الله باقشير لكي تكون عندك فكرة عن المصفوفات http://www.officena.net/ib/index.php?showtopic=42397 http://www.officena.net/ib/index.php?showtopic=42584 المهم بعد تحميل محتوى اليست بوكس الى المصفوفة مع ادخال البيانات التي نريد اذخالها و الى المكان او الخلية التي نريدها بكل بساطة نعيد ملئ اليست بوكس هذه المرة بمحتو المصفوفة التي عملناها فقط ارجو ان تكون الفكرة قد وصلت تحياتي للجميع

السلام عليكم هذيه الطريقة تعتمد على تحميل محتوى اليست الى مصفوفة ديناميكية ومن ثما تغير الخلية التي تريد ثم ارجاع محتوى المصفوفة الى اليست بعد التعديل تحياتي للجميع المصنف1.rar

السلام عليكم هي فكرة وددت مشاركتكم ايها ولاثبات انه يمكن تقوية حماية الاكسل ايضا هذا مثال قمت بحمايته بطريقة الخاصة ارجو منكم محاولت كسر حمايته الى ذلك الحين لنا كلام اخر ملاحضة لايوجد في اي لغة برمجة ما يسمى بالحماية الكاملة فالكمال لله ولاي قفل مفتاح تحياتي RABIE TEST.rar

السلام عليكم http://www.officena.net/ib/index.php?showtopic=53126#entry333488 http://www.officena.net/ib/index.php?showtopic=46463#entry277636

عدد الشيتات غير محدو كلما تضيف شيت يضاف تلقائيان في قاعدة البيانات الخاصة بالصلاحيات

السلام عليكم اعتذر لك اخي ياسر عن غيابي الفترة الي فاتت هذا كود مميز لتعبئة اليست بوكس أو الكمبو بكس من عمود بدون تكرار Option Explicit Private Sub UserForm_Initialize() Dim i As Integer Dim Valeurs As Variant Dim sDic As Object: Set sDic = CreateObject("Scripting.Dictionary") Me.ListBox1.Clear Me.ComboBox1.Clear With Sheets(1) Valeurs = .Range("A1:A100").Value For i = LBound(Valeurs) To UBound(Valeurs) If Not IsEmpty(Valeurs(i, 1)) Then sDic(Valeurs(i, 1)) = "" Next i End With If IsArray(Valeurs) Then ListBox1.List = sDic.keys: ComboBox1.List = sDic.keys End Sub تحياتي للجميع RABIECHAOUKI.rar

السلام عليكم بارك الله فيك وجازك كل الخير اخي الصقر الجريح عندي تعقيب بسيط على الموضوع ارجو ان تتقبله بصدر رحب لانه لاغاية لي الى اثراء الموضوع اولا عندما نعطل احد وضائف المصنف مثلا كود تثبيت الشاشة Application.ScreenUpdating = False من الافضل ارجاعه الى وظيفته الافتراضية عند نهاية الكود Application.ScreenUpdating = True ثانيا في كود معرفة اخر خلية تحوي بيانات في العمود بما انك ستتعامل مع الخلية التي تليه يكون من الافضل اضافة الواحد في الكود نفسه بدلا من تكرار العملية مع كل خلية سترحل لها البيانات lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1 ثالث هنا عملية الترحيل بسيطة وليس فيها الكثير من البيانات فرضا انه لدينا بيانات كثيرة سترحل سيكون من الافضل استخدام الحلاقات الدورانية لتنفيذ المطلوب لاكن في المثال السابق ليس من المستحسن استخدامها لان ترتيب البيانات المرحلة متخالف مع المرحل اليها انما سيربكنا استعمالها لذى افضل استخدام المصفوفات التي تتسم بالسرعة الفائقة في التنفيذ و اختزال الاسطر الكثيرة ليكون المثال السابق كالاتي Sub ترحيل() Application.ScreenUpdating = False With Sheet4 lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1 ' مصفوفة تحوي البيانات التي سترحل حسب ترتب الترحيل Dim Matrix: Matrix = Array([D8], [G7], "", [D10], "=R[-1]C+RC[2]-RC[1]", "", [d11]) 'كود الترحيل بستخدام المصفوفة و دالة Resize .Range("A" & lr).Resize(1, 7).Value = Matrix End With Application.ScreenUpdating = True End Sub في الاخير ارجو ان تكون فكرتي وصلت وان تستفيدو منها واكرر اعتذاري للاخ الصقر الجريح وارجو ان لا اكون قد تطاولت على موضوعه تحياتي للجميع

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

السلام عليكم لتنفيذ طلبك هناك العديد من الطرق الممكنة وكلها تفي بالغرض لاكن كل واحد وطريقته وهذي طريقة الشخصية Dim wsh As Worksheet Dim lMh As Long Dim iCont As Integer Private Sub ComboBox1_Change() Dim di As Double: di = Me.ComboBox1.Value Set wsh = ThisWorkbook.Sheets("data") With wsh lLrw = wsh.Cells(.Rows.Count, "B").End(xlUp).Row lMh = WorksheetFunction.Match(di, .Range("B2:B" & lLrw), 0) + 1 iCont = WorksheetFunction.CountIf(.Range("B2:B" & lLrw), di) End With Me.ListBox1.List = wsh.Range("A" & lMh).Resize(iCont, 7).Value End Sub Private Sub CommandButton1_Click() Set wsh = ThisWorkbook.Sheets("data") Dim iListCont As Integer: iListCont = Me.ListBox1.ListCount With wsh .Unprotect (123) .Range("A" & lMh & ":E" & iCont).ClearContents .Range("A" & lMh).Resize(iCont, 7).ClearContents .Range("A" & lMh).Resize(iListCont, 7).Value = Me.ListBox1.List() .Protect (123) End With End Sub Private Sub UserForm_Initialize() Set wsh = ThisWorkbook.Sheets("data") With wsh lLrw = wsh.Cells(wsh.Rows.Count, "B").End(xlUp).Row Dim dMN As Double: dMN = WorksheetFunction.Min(.Range("B2:B" & lLrw)) Dim dMX As Double: dMX = WorksheetFunction.Max(.Range("B2:B" & lLrw)) End With If dMN Then Me.ComboBox1.List = Evaluate("ROW(" & dMN & ":" & dMX & ")") Me.ListBox1.ColumnCount = 7 End Sub Private Sub Listbox1_dblClick(ByVal Cancel As MSForms.ReturnBoolean) ListBox1.RemoveItem (ListBox1.ListIndex) End Sub ضع الاكواد السابقة في الفورم لحذف صنف من فاتورة اضغط دوبل كليك عليه من اليست بوكس سيحذف من الليست و بعدها اضغط زر حذف لحدفه من قاعدة البيانات تحاتي ‫طارق زكريا - نسخة.rar

السلام عليكم كود لتوليد كود عشوائي (سيريل نمبر عشوائي) Sub Code_Aléatoire() Randomize Dim sCarac As String: sCarac = "ABCDEFGKHLMNPQRSTWXYZ0123456789" Dim sLettre As String: sLettre = "" Dim bI As Byte, bNombre As Byte For bI = 1 To 20 bNombre = Int(Len(sCarac) * Rnd) + 1 sLettre = sLettre & Mid(sCarac, bNombre, 1) If bI Mod 5 = 0 Then sLettre = sLettre & "-" Next MsgBox Mid(sLettre, 1, 23) End Sub تحياتي

السلام عليكم دالة استخراج اخر يوم من الشهر Function NB_JOURS(date_test As Date) NB_JOURS = Day(DateSerial(Year(date_test), Month(date_test) + 1, 1) - 1) End Function ضع الكود في موديل ثم في ورقة العمل أدرج الدالة كاي دالة اخرى تجدها باسم NB_JOURS السيغة العامة لدالة تكون =NB_JOURS(A1) تحياتي