شوقي ربيع

السلام عليكم الشكر موصول لكل الاعضاء جرب هذا الكود Sub TEST() Dim x(): x = Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value Dim i As Integer: For i = 1 To UBound(x) Dim n: n = n + 4: Range("G" & n).Resize(4, 1).Value = x(i, 1) Next: End Sub هذا كود اخر اسرع من الكود الاول Sub TEST2() Dim ObjCell As Range For Each ObjCell In Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row).Cells Dim n: n = n + 4: Range("G" & n).Resize(4, 1).Value = ObjCell.Value Next End Sub

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

السلام عليكم المشكلة في تعارض الاصدار بين الاوفس ال\ي لديك وال\ي لدي ما بخصوص سؤالك اجل تضهر الاسماء المكتوبة بالعربي على العموم قم بادراج كمبوبوكس في الشيت الخاص بك من مطور و يجب ان يكون اسمها ComboBox1 ان لم يكن غير التسمية في الاكواد ثانيا انشء نوديل وانسخ فيه هذه الاكواد Public sDic As Object Public choix1() Sub RabieCh() Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sales Report") Dim lrw As Long: lrw = ws.Cells(Rows.Count, 1).End(xlUp).Row Dim keyArray(): keyArray = ws.Range("A3:A" & lrw).Value Set sDic = CreateObject("Scripting.Dictionary") Dim i As Long For i = LBound(keyArray) To UBound(keyArray) If Not IsEmpty(keyArray(i, 1)) Then sDic(keyArray(i, 1)) = "" Next i If IsArray(keyArray) Then With Sheet2.ComboBox1 .List = sDic.keys: .ListRows = 20 .MatchEntry = fmMatchEntryNone .TextAlign = fmTextAlignRight End With choix1 = sDic.keys End If End Sub وفي حدث Change الخاص بالكمبوبوكس انسخ الكود الاتي Private Sub ComboBox1_Change() If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, choix1, 0)) Then Me.ComboBox1.List = Filter(choix1, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If End Sub ان شاء الله سيعمل لديك الملف عادي تحياتي

السلام عليكم اخي ياسر المشكلة كلها بسبب التحديث الاخير الذي عملته مكروسوفت لانو فيه مشاكل كثيرة وانا لم اكن موقف التحديث التلقائي فحدث من نفسو وايضا هناك بعض التخاذل مني لضبط الاوفيس عندي يعني ارجعه لسابق عهده او اعيد تنصيبو من جديد لانو فيه حاجات اخرى لا اريد ان افقدها بخصوص المشكلة في التحدث كمثال لما تضيف اي ابجت في الشيت من المطور ونقلا مثلا TextBox من المفروض تجدها بأسم TextBox1 لاكن تجدها بأسم TextBox21 هذه الاكواد المستعملة في الملف انسخها في الملف الاول ان اشتغل لديك او انشء ملف جديد كما هو الحال في الملف الاول ثم انسخ فيه الاكواد Dim keyArray() Dim keyArray2() Dim itemArray() Dim element Dim a, b, d, e, i Private Sub ComboBox2_Change() If ComboBox1 = "" Then MsgBox "اختر الشهر أولا": Exit Sub d = Me.ComboBox2 e = 0 Dim bMonth As Byte Dim x As Integer: x = 0 Me.TextBox1.Value = 0 For i = LBound(keyArray) To UBound(keyArray) bMonth = Month(keyArray(i, 1)) If d = "كل الاصناف" And bMonth = ComboBox1.ListIndex + 1 Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 4) itemArray(3, e) = keyArray(i, 5) itemArray(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) ElseIf keyArray(i, 4) = d And bMonth = ComboBox1.ListIndex + 1 Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 4) itemArray(3, e) = keyArray(i, 5) itemArray(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) End If Next i If e > 0 Then If UBound(itemArray, 2) > 1 Then Me.ListBox1.List = Application.Transpose(itemArray) Else Dim c(1 To 1, 1 To 4) c(1, 1) = itemArray(1, 1) c(1, 2) = itemArray(2, 1) c(1, 3) = itemArray(3, 1) c(1, 4) = itemArray(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Me.TextBox1.Value = x End Sub Private Sub ComboBox3_Change() If ComboBox4 <> "" Then Call ComboBox4_Change End Sub Private Sub ComboBox4_Change() If ComboBox3 = "" Then MsgBox "فضلا اختر تاريخ بداية البحث أولا": Exit Sub Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("data") If IsDate(ComboBox3) Then a = CDate(Me.ComboBox3.Value) Else Exit Sub If IsDate(ComboBox4) Then b = CDate(Me.ComboBox4.Value) Else Exit Sub e = 0 Dim x As Integer: x = 0 For i = LBound(keyArray) To UBound(keyArray) If a <= CDate(keyArray(i, 1)) And b >= CDate(keyArray(i, 1)) Then e = e + 1: ReDim Preserve keyArray2(1 To 4, 1 To e) keyArray2(1, e) = keyArray(i, 1) keyArray2(2, e) = keyArray(i, 4) keyArray2(3, e) = keyArray(i, 5) keyArray2(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) End If If e > 0 Then If UBound(keyArray2, 2) > 1 Then Me.ListBox1.List = Application.Transpose(keyArray2) Else Dim c(1 To 1, 1 To 4) c(1, 1) = keyArray2(1, 1) c(1, 2) = keyArray2(2, 1) c(1, 3) = keyArray2(3, 1) c(1, 4) = keyArray2(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Next Me.TextBox1.Value = x End Sub Private Sub CommandButton1_Click() Dim i% i = Me.ListBox1.ListCount Sheets("طباعة").Range("A1").Value = "تقرير شهر" & " " & Me.ComboBox1 & "صنف" & " " & Me.ComboBox2 Sheets("طباعة").Range("A3:d1000").ClearContents With Sheets("طباعة").Range("A3") If i = 0 Then GoTo 1 .Resize(i, 4).Value = Me.ListBox1.List End With lr = Sheets("طباعة").Range("d1000").End(xlUp).Row Sheets("طباعة").Range("d" & lr + 1).Value = Application.WorksheetFunction.Sum(Sheets("طباعة").Range("d2:d" & lr)) Sheets("طباعة").Range("d" & lr + 1).Offset(0, -1).Value = Application.WorksheetFunction.Sum(Sheets("طباعة").Range("c2:c" & lr)) Sheets("طباعة").Range("d" & lr + 1).Offset(0, -2).Value = "الإجمالي" Sheets("طباعة").Select ActiveSheet.PageSetup.PrintArea = "A1:D" & lr + 1 Unload Me ActiveWindow.SelectedSheets.PrintPreview a = MsgBox("هل ترغب في طباعة التقرير؟", vbYesNo + vbQuestion, "طباعة") If a = vbYes Then With ActiveSheet .PrintOut End With End If Range("A3").Activate 1 Unload Me End Sub Private Sub UserForm_Initialize() Me.RightToLeft = False ComboBox1.List = Array("يناير", "فبراير", "مارس", "ابريل", "مايو", "يونيو", "يوليو", "اغسطس", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر") Me.ListBox1.ColumnCount = 4 Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("data") Dim iRow As Long: iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row Dim sDic, sDic2 As Object Set sDic = CreateObject("Scripting.Dictionary") Set sDic2 = CreateObject("Scripting.Dictionary") keyArray = ws.Range("A3:G" & iRow).Value For i = LBound(keyArray) To UBound(keyArray) If Not IsEmpty(keyArray(i, 4)) Then sDic(keyArray(i, 4)) = "" If Not IsEmpty(keyArray(i, 1)) Then sDic2(keyArray(i, 1)) = "" Next i If IsArray(keyArray) Then ComboBox2.List = sDic.keys If IsArray(keyArray) Then ComboBox3.List = sDic2.keys: ComboBox4.List = sDic2.keys ComboBox2.AddItem "كل الاصناف" End Sub

معذرتا تحية كبيرة للاخ محمد الريفي لحلوله الجميلة بالمعادلات جزاك الله خيرا

السلام عليكم هذا حل بالاكواد كود ملئ اليست دون تكرار Sub RabieCh() Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sales Report") Dim lrw As Long: lrw = ws.Cells(Rows.Count, 1).End(xlUp).Row Dim keyArray(): keyArray = ws.Range("A3:A" & lrw).Value Set sDic = CreateObject("Scripting.Dictionary") Dim i As Long For i = LBound(keyArray) To UBound(keyArray) If Not IsEmpty(keyArray(i, 1)) Then sDic(keyArray(i, 1)) = "" Next i If IsArray(keyArray) Then With Sheet2.ComboBox1 .List = sDic.keys: .ListRows = 20 .MatchEntry = fmMatchEntryNone .TextAlign = fmTextAlignRight End With choix1 = sDic.keys End If End Sub كود البحث داخل اليست (فلترة) If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, choix1, 0)) Then Me.ComboBox1.List = Filter(choix1, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If لم افهم اين تريد انتائج ان شات وضح الامر لاعدل في الاكواد تحياتي للجميع قائمة منسدلة بدون تكرار مع إمكانية البحث داخل القائمة.rar

بصراحا اخي لم افهم شيء في الملف ممكن توضح اكثر

لا يوجد مرفق ارفق ملف اشرح فيه الذي تريده وان شاء الله سنساعدك

السلام عليكم تم استخدام كمبوبوكس بدلا من التكست بوكس للبحث تم اضافة قموس ثاني لملىء الكمبوبوكس الخاصة بالتاريخ بدون تكرار If Not IsEmpty(keyArray(i, 1)) Then sDic2(keyArray(i, 1)) = "" If IsArray(keyArray) Then ComboBox3.List = sDic2.keys: ComboBox4.List = sDic2.keys وهذا الكود المستعمل في البحث ايضا يعتمد على المصفوفات يقوم بملىء اليست بوكس حسب الفترة التي تختارها مع اعطاء مجموع تلك الفترة في تكستبوكس المجموع If ComboBox3 = "" Then MsgBox "فضلا اختر تاريخ بداية البحث أولا": Exit Sub Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("data") If IsDate(ComboBox3) Then a = CDate(Me.ComboBox3.Value) Else Exit Sub If IsDate(ComboBox4) Then b = CDate(Me.ComboBox4.Value) Else Exit Sub e = 0 Dim x As Integer: x = 0 For i = LBound(keyArray) To UBound(keyArray) If a <= CDate(keyArray(i, 1)) And b >= CDate(keyArray(i, 1)) Then e = e + 1: ReDim Preserve keyArray2(1 To 4, 1 To e) keyArray2(1, e) = keyArray(i, 1) keyArray2(2, e) = keyArray(i, 4) keyArray2(3, e) = keyArray(i, 5) keyArray2(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) End If If e > 0 Then If UBound(keyArray2, 2) > 1 Then Me.ListBox1.List = Application.Transpose(keyArray2) Else Dim c(1 To 1, 1 To 4) c(1, 1) = keyArray2(1, 1) c(1, 2) = keyArray2(2, 1) c(1, 3) = keyArray2(3, 1) c(1, 4) = keyArray2(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Next Me.TextBox1.Value = x تحياتي للجميع كود البحث بين تاريخين.rar

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

السلام عليكم Sub Test() Dim wS1 As Worksheet: Set wS1 = Feuil1 Dim wS2 As Worksheet: Set wS2 = Feuil2 Dim Lrw As Long: Lrw = wS1.Cells(Rows.Count, "E").End(xlUp).Row Dim n As Long Dim i As Byte, ii As Byte Dim x As Double For i = 4 To 15 n = 0: x = 0: For ii = 3 To Lrw If Month(CDate(wS1.Range("E" & ii).Value)) = i - 3 Then n = n + 1: wS2.Range("E" & i).Value = n x = x + wS1.Range("D" & ii).Value wS2.Range("D" & i).Value = x End If: Next: Next: End Sub حساب قيمة الخلايا وعدد الخلايا.rar

السلام عليكم الشكر موصول لاخي ياسر لاثراء الموضوع يتم الامر ايضا بالاكواد ب للحصول على حروف كبيرة x = UCase(Text) للحصول على الحروف الصغيرة x = LCase(Text) النص يوضع مكان عبارة Text بين مزدوجتين " "

السلام عليكم Sub test() Dim ws1 As Worksheet: Set ws1 = Sheets("invoice") Dim ws2 As Worksheet: Set ws2 = Sheets("mat") Dim lrw1 As Long: lrw1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row Dim lrw2 As Long: lrw2 = ws2.Cells(Rows.Count, "F").End(xlUp).Row + 1 Dim i As Byte: i = lrw2 - 1 + lrw1 - 9 If ws1.Range("D10") = "" Then Exit Sub Dim ii As Byte: For ii = lrw2 To i ws2.Range("C" & ii).Value = ws1.Range("E3").Value ws2.Range("D" & ii).Value = ws1.Range("I3").Value ws2.Range("E" & ii).Value = ws1.Range("E5").Value ws2.Range("M" & ii).Value = ws1.Range("E7").Value Next ws2.Range("F" & lrw2 & ":L" & i).Value = ws1.Range("D10:J" & lrw1).Value ws1.Range("C10:J" & lrw1).Value = "" End Sub الفاتورة_2.zip

السلام عليكم مشاء الله اخي مختار عمل جميل ومنظم جزاك الله خيرا وبارك الله لك على الجهد الذي بذلته في هذا العمل تحياتي لك

السلام عليكم جزاك الله خير اخي محمود يسعدني ان ارى استغلال المواضيع التي نطرحها في المنتدى والا فما الفائدة منها فقط ملاحظة بسيط الملف المدرج على الاغلب لن يشتغل عند كل الاعضاء لانه يعتمد على ادوات اضافية فيها مشاكل مع نسخ الوينداوز و هذا المشكل لطالما ما ارقني ولم اجد له حل سوى ان تصمم برنامجك على نسخة وينداو قديمة مثل XP PAK 1 على العموم جهد جميل وواصل على ه\ا المنوال تحياتي وشكرا مرة اخرى

السلام عليكم كل الاصناف تجدها اخر قائمة الاصناف تم اضافة عبارة كل الاصناف في حدث الاقلاع ComboBox2.AddItem "ßá ÇáÇÕäÇÝ" اما كود البحث اصبح هكذا If ComboBox1 = "" Then MsgBox "ÇÎÊÑ ÇáÔåÑ ÃæáÇ": Exit Sub d = Me.ComboBox2 e = 0 Dim bMonth As Byte Dim x As Integer: x = 0 Me.TextBox1.Value = 0 For i = LBound(keyArray) To UBound(keyArray) bMonth = Month(keyArray(i, 1)) If d = "ßá ÇáÇÕäÇÝ" And bMonth = ComboBox1.ListIndex + 1 Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 4) itemArray(3, e) = keyArray(i, 5) itemArray(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) ElseIf keyArray(i, 4) = d And bMonth = ComboBox1.ListIndex + 1 Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 4) itemArray(3, e) = keyArray(i, 5) itemArray(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) End If Next i If e > 0 Then If UBound(itemArray, 2) > 1 Then Me.ListBox1.List = Application.Transpose(itemArray) Else Dim c(1 To 1, 1 To 4) c(1, 1) = itemArray(1, 1) c(1, 2) = itemArray(2, 1) c(1, 3) = itemArray(3, 1) c(1, 4) = itemArray(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Me.TextBox1.Value = x End Sub كل الاصناف.rar

chaouki.rar

السلام عليكم صممت لك هته المعادلة ستفي بالغرض ان شاء الله Function Rabie(Tst As String) As String Dim bLen As Byte: bLen = Len(Tst) Dim sName As String Dim i As Long: For i = 1 To bLen Step 3 sName = sName & Chr(Mid(Tst, i, 3)) Next Rabie = sName End Function chaouki.rar

الكود السابق ليس له اي علاقة مع لحذف هو بيقول لم تكتب من 1 في العمود C بيعطيك اولى ابتدائي وهكذا ولا لما تكتب ك في العمود d بيعطي ذكر شوف ان كان هناك اكواد اخرى ادرجها لكي نشوف اين الخطاء للاسم لم يشتغل الملف عندى لاكان الامر اسهل

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

السلام عليكم اولا لم اجد الكود السابق في الملف المرفق ثانيا توجد حاجا اسمها الحلاقات التكرارية تغنيك عن مئات الاسطر وهذا التعديل للكود الذي ادرجته اعلاه على حسب فهمي للطلبك Sub AddData() Application.ScreenUpdating = False smsm.Range("d12").Select If smsm.Range("d12").Value = "" Then MsgBox "ÇáÑÌÇÁ ÇÏÎÇá ÇáÇÓã ÞÈá ÚãáíÉ ÇáÇÖÇÝÉ" Exit Sub End If Dim en As Long: en = good.Range("e15000").End(xlUp).Row + 1 Dim i As Long: For i = 2 To 54 good.Cells(en, i) = smsm.Range("d" & i + 8).Value Next smsm.Range("d11:e11,d12:e12,c15:e34").ClearContents good.Range("b8:h1000").Sort Key1:=good.Range("b8"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal smsm.Range("e9") = smsm.Range("e9") + 1 smsm.Range("c11").Select End Sub

نفس المشكلة الملف لا يشتغل ماهو العمود الذي تحذف منه الطالب ملاحظة حسب ماشاهدة من الكود الذي ادرجته فان الحماية تفك عند حدوث اي تغير في الشيت من العمود 2 الى العمود 3 ممكن وجود تعارض مع احد الاكواد السابقة والله اعلم وايضا لمدا تكرار هدا الجزء من الكود With Range("b18:b" & LR + 3) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True End With

السلام عليكم الملف لم يشتغل عندي على العموم لفك الحماية وارجاعها من اجل تنفيذ كود ما تكو الصيغة هكذا ActiveSheet.Unprotect Password:=123 ' . ' . ' . ' هنا ضع الكود الذي تريد تنفيذه ' . ' . ActiveSheet.Protect Password:=123

السلام عليكم اولا من الافضل عدم توجيه طلباتك الى اعضاء معينين لان هذا ممكن يمنع من يريد المساعدة من مساعدتك وايضا من الممكن ان من طلبت منهم المساعدة يكونو غير متوفرين وهذا الحل لملفك Dim lLrw1 As Long, lLrw2 As Long If TextBox1 = "" Then Exit Sub Dim b As Long: b = Me.TextBox1.Value For Each ws In ThisWorkbook.Sheets lLrw1 = ws.Cells(1, "c").End(xlDown).Row + 1 lLrw2 = ws.Cells(Rows.Count, "c").End(xlUp).Row Dim i As Long: For i = lLrw1 To lLrw2 ws.Range("B" & i) = b b = b + 1 Next Next هذا الكود يعمل على كافت الشيتات الموجودة في الملف فقط حدد رقم البداية في التكست بوكس واضغط الزر الترقيم الالي للخلايا عن طريق تاكس بوكس في الفورم.rar

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