ياسر خليل أبو البراء

أخي الحبيب ياسر الشيخ أعتذر عن التأخير في الرد حيث أنني كنت مشغول حين طلبت شرح الكود .. ونسيت بسبب الزهايمر هذا شرح متواضع حسب فهمي البسيط للمصفوفات حيث انني لست خبيراً في التعامل مع المصفوفات Private Sub UserForm_Initialize() 'تعريف المتغيرات Dim A, E 'مسح محتويات الكومبوبوكس ComboBox2.Clear '[Sheet1] بدء التعامل مع ورقة العمل المسماة برمجياً With Sheet1 'ليحمل قيم النطاق في العمود الثاني أي أنها تعتبر مصفوفة بكل القيم في هذا النطاق [A] تعيين قيمة للمتغير A = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).value End With 'بدء التعامل مع المصفوفات With CreateObject("System.Collections.ArrayList") '[Aِ] من عناصر المصفوفة [E] عمل حلقة تكرارية لكل عنصر For Each E In A 'إذا كان العنصر لا يساوي فراغ ولا يوجد عنصر مماثل في المصفوفة أي يتم التعامل مع القيم الفريدة If (E <> "") * (Not .Contains(CStr(E))) Then 'يتم إضافة العنصر إلى المصفوفة الجديدة التي تحتوي على قيم فريدة غير مكررة .Add CStr(E) End If Next 'ترتيب عناصر المصفوفة الجديدة .Sort 'إضافة عناصر المصفوفة الجديدة للكومبوبوكس ComboBox2.List = .ToArray End With End Sub تقبل تحياتي

الأخ الفاضل منير مشكور على التوضيح التاااااااااام لطلبك بشكل ممتاز هكذا يكون التوضيح جرب الكود بهذا الشكل وإن شاء الله يفي بالغرض Sub NewMonth_Sheet() Dim lSht As Worksheet Dim nSht As Worksheet Dim shName As String Set lSht = Sheets(Sheets.Count) If IsDate(lSht.Name) Then shName = Application.Proper(Format(DateAdd("m", 1, lSht.Name), "mmmm-yyyy")) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error Resume Next 'Tests that sheet doesn't already exist Set nSht = Sheets(shName) On Error GoTo 0 If nSht Is Nothing Then lSht.Copy after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = shName Else MsgBox "Sheet """ & shName & """ already exists!", vbCritical End If Else MsgBox "Last sheet name does not" & Chr(10) & "represent a month!", vbCritical: Exit Sub End If For Each ce In [B9:J39] If ce.HasFormula = True Then GoTo 10 ce.ClearContents 10 Next 'هذه الأسطر من الكود لتحقيق المطلوب Sheets("Total Général").Activate Range("D" & Cells(Rows.Count, 4).End(xlUp).Row - 1).EntireRow.Copy Range("A" & Cells(Rows.Count, 4).End(xlUp).Row).EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub تم إضافة 4 أسطر في الكود قبل آخر سطرين تقبل تحياتي

جزيت خيراً أخي الغالي حسام عيسى على هذه المعلومات القيمة موسوووووووووووعة

الأخ الفاضل نجمه إليك هذا الرابط قد يفيدك http://www.officena.net/ib/index.php?showtopic=60730&hl=

أخي محمد الخازمي في الخلية E10 ضع المعادلة التالية =IFERROR(INDEX($B$18:$B$300,COUNTA($B$18:$B$300)-1+ROW(A1)),"") للحصول على آخر اسم في القائمة أما بالنسبة لأول اسم فيكفي على ما أعتقد ان تشير إلى الخلية B18 =B18 تقبل تحياتي

أخي الفاضل رشراش علي كيف تفشل العملية ؟؟ هل جربت الترتيب بالشكل المعتاد .. أن تحدد الجدول ثم من التبويب Data ثم الأمر Sort وتحدد في الحقل الأول العمود E على أساس أنه شرط الترتيب وتختار من آخر حقل من الأقدم للأحدث أو من الأحدث للأقدم ..

أخي الفاضل العمري الحمد لله أن تم المطلوب على خير ... بالنسبة للخطأ في السطر المذكور يرجع إلى عدم وجود ورقة عمل اسمها البرمجي Sheet1 قد تكون باسم ورقة1 أو Feuil1 ..حسب الملف لديك .. عموماً هذا السطر لن يؤثر في شيء لأنه يحدد فقط ورقة العمل بعد الانتهاء من تنفيذ الكود والشكر موصول لصاحب القبول الأخ الكبير سليم حاصبيا الذي أثرى الموضوع بشكل رائع تقبلوا تحياتي

جزاك الله خيراً أخي الحبيب صلاح على هذه الكلمات الرقيقة .. روح ربنا يبارك فيك .. المهم تكون استفدت من الملف الكود بيعتمد على جلب بيانات من ملف حسابات العملاء .. ففيه حلقة تكرارية لكل ورقة من أوراق العمل في المصنف " الأقساط الشهرية" اللي فيه الشهور المفروض تتوزع عليها البيانات .. وداخل كل حلقة بيتم التعامل مع المصنف التاني "حسابات العملاء" بيتم أيضا الحلقات التكرارية لكل أوراق العمل ، وداخل كل ورقة عمل بيتم عمل حلقة تكرارية للعمود الأول لاستخراج رقم الشهر .. ومن خلال رقم الشهر بنشوف هل رقم الشهر بيساوي أي رقم ونترجمه لمرادفه من أسماء الشهور .. يعني الرقم 1 معناه يناير وهكذا ..عشان يتم وضع كل بيان في ورقة العمل المناسبة في المصنف "الأقساط الشهرية" ..يعني الملف فيه حلقات جننتني ..عشان دي أول مرة أكتب فيها 3 حلقات في كود واحد ..أنا كان آخري حلقتين بس الحمد لله تم بحمد الله وتحقق المطلوب وتم جلب البيانات في كل ورقة عمل بما يتناسب مع التاريخ لكل بيان تقبل تحيااتي

أخي الفاضل أمين بكر ممكن تطلع على هذا الموضوع (وكل لبيب بالإشارة يفهم) http://www.officena.net/ib/index.php?showtopic=60147 تقبل تحياتي

أخي سليم أيوا .. بس الفترات ما بين الثلاثة ورقات عمل 10 - 15 - 20 على أوراق العمل ورقة العمل 3 - 4 - 5 وبيتكرر مرة تانية !! يعني عدد مرات التكرار مرتين .. والفترات ثابتة ..

شيل كلمة Data من المعادلة وضع مكانها كلمة Table2 .. بس خلاص

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

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

الأخ الفاضل أمين .. نورت المنتدى بين إخوانك إليك الملف التالي عله يفي بالغرض تم تسمية نطاق البيانات باسم Data .. ايصال دفع.rar

أخي الحبيب سليم إزاي أسيبه مقدرش !! لأنه محددش الكلام اللي بتقوله ... الكلام على عمل حلقة تكرارية للكود .. خلتني أقرا المشاركة الأولى مرتين عشان أتأكد من كلامي ، أي أنه لم يحدد فترات زمنية على الإطلاق .. وكمان لم يحدد عدد مرات التكرار بس دي مكانش ينفع نسيبها مفتوحة لأن لو سبناها مفتوحة ومربطنهاش هيفضل يكرر للأبد تقبل تحياتي

أخي الكريم جرب الكود بهذا الشكل : Private Sub CommandButton1_Click() Dim iRow As Long Dim ws As Worksheet Dim T As Long Set ws = Worksheets("Feuil1") iRow = ws.Cells(Rows.Count, 8).End(xlUp).Row + 1 ws.Cells(iRow, 8).Value = Me.TextBox1.Value ws.Cells(iRow, 9).Value = Me.TextBox2.Value ws.Cells(iRow, 10).Value = Me.TextBox3.Value ws.Cells(iRow, 11).Value = Me.TextBox4.Value ws.Cells(iRow, 12).Value = Me.TextBox5.Value Me.TextBox1 = "" Me.TextBox2 = "" Me.TextBox3 = "" Me.TextBox4 = "" Me.TextBox5 = "" T = ws.Cells(Rows.Count, 8).End(xlUp).Row TextBox1 = Val(Cells(T, 8)) + 1 Me.TextBox1.SetFocus End Sub Private Sub UserForm_activate() Dim ws As Worksheet Dim T As Long Set ws = Worksheets("Feuil1") T = ws.Cells(Rows.Count, 8).End(xlUp).Row TextBox1 = Val(Cells(T, 8)) + 1 Me.TextBox2.SetFocus End Sub تقبل تحياتي

أخي الحبيب صلاح من كان حليفاً فليحلف بالله أو ليصمت .. قول بالله عليك ويا سيدي الحال من بعضه .. بس أنا دققت شويتين عشان أكتب لك المعادلة =AND($C$6<>"",OR($C$6=$B8:$E8)) وإنت تؤمرني

أخي الفاضل عبد العزيز البسكري '[Feuil1] تعيين قيمة للمتغير تساوي رقة العمل المسماة Set ws = Worksheets("Feuil1") 'تحديد آخر صف به بيانات 'تعني عدد صفوف ورقة العمل بالكامل[Rows.Count]الجملة '[C]الرقم 3 يمثل رقم العمود وهو هنا العمود الثالث أي العمود 'تعني الإراحة بمقدار 5 صفوف إلى أسفل بعد الوصول لآخر خلية بها بيانات[Offset]الجملة iRow = ws.Cells(Rows.Count, 3).End(xlUp).Offset(5, 0).Row تقبل تحياتي

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

ايه الكسل دا يا حاج صلاح !!! شوف الصورة واكتبها والصقها في مشاركة ليستفيد غيرك هههه

أخي الفاضل سامي لم أقصد الإحباط أبداً .. وشعاري دائماً حاول وافشل يكفيك شرف المحاولة.. إنما كان ردي لأوصل لكم انني حاولت ليس أكثر ولا أقل .. وإن شاء الله تجد من يساعدك تقبل إحباطي قصدي تحياتي يا أخي (لخبطني)

الأخ الحبيب سليم بارك الله فيك بعد إذنك جرب الكود التالي .. Sub LoopThroughSheets() Dim rNumber As Long, I As Long, X As Long 'عدد مرات التكرار rNumber = 2 'بداية الثواني X = 10 For I = 1 To rNumber 'حلقة تكرارية لأوراق العمل For II = 3 To 5 Application.Wait (Now + TimeValue("0:00:" & X)) X = X + 5 Sheets(II).Select Next II X = 10 Next Sheet1.Activate End Sub

الأخ الحبيب محبوب تعبت والله ..بقالي ساعتين عشان أعمل الكود الملعبك ده بس الحمد لله بفضل الله تم المطلوب .. افتح ملف "الأقساط الشهرية 2015" ستجد الكود بداخله .. في ورقة الفهرس يوجد زر امر انقر عليه لتنفيذ الكود .. Sub YasserKhalil() Dim WBK As Workbook Dim SH As Worksheet, WS As Worksheet, Cell As Range Application.ScreenUpdating = False Application.DisplayAlerts = False Set WBK = Workbooks.Open(ThisWorkbook.Path & "\حسابات العملاء 1.xlsx") For Each SH In ThisWorkbook.Sheets If SH.Name <> "الفهرس" Then SH.Range("C6:F99,H6:I99").ClearContents For Each WS In WBK.Sheets If WS.Name <> "الفهرس الرئيسى" Then With WS If IsEmpty(.Range("A6")) Then GoTo 1 For Each Cell In .Range("A6:A" & .Cells(Rows.Count, 1).End(xlUp).Row) If Month(Cell.Value) = MonthNumber(SH.Name) Then SH.Range("H" & SH.Cells(99, 8).End(xlUp).Row + 1) = Cell.Value SH.Range("C" & SH.Cells(99, 3).End(xlUp).Row + 1) = .Range("C2").Value SH.Range("E" & SH.Cells(99, 5).End(xlUp).Row + 1) = Cell.Offset(, 2) SH.Range("F" & SH.Cells(99, 6).End(xlUp).Row + 1) = Cell.Offset(, 3) SH.Range("I" & SH.Cells(99, 9).End(xlUp).Row + 1) = .Range("M8").Value End If Next Cell 1 End With End If Next WS End If Next SH WBK.Close SaveChanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Function MonthNumber(MonthName As Variant) As Variant Select Case MonthName Case "": MonthNumber = "" Case "يناير": MonthNumber = 1 Case "فبراير": MonthNumber = 2 Case "مارس": MonthNumber = 3 Case "ابريل": MonthNumber = 4 Case "مايو": MonthNumber = 5 Case "يونيو": MonthNumber = 6 Case "يوليو": MonthNumber = 7 Case "اغسطس": MonthNumber = 8 Case "سبتمبر": MonthNumber = 9 Case "اكتوبر": MonthNumber = 10 Case "نوفمبر": MonthNumber = 11 Case "ديسمبر": MonthNumber = 12 End Select End Function تقبل تحياتي ولا تنسى أن تحدد المشاركة إذا أعجتك الإجابة كأفضل إجابة (ساعتين مني قصاد ثانيتين منك .. أظن كدا عدل والحمد لله) Three Loops In Two Excel Files By YasserKhalil.rar

الأخ الكريم صلاح الدين جرب الكود التالي وشوف هل يؤدي الغرض أم لا Sub ss() Dim LR As Long Application.ScreenUpdating = False Workbooks.Open Filename:="D:\z.xls" With Workbooks("z") .Sheets("total").Range("A2:P1000").ClearContents With Workbooks("تفاصيل").Sheets("تفاصيل") .Activate .Range("A2:P" & .Cells(Rows.Count, 2).End(xlUp).Row).Copy End With LR = .Sheets("total").Range("A1").CurrentRegion.Rows.Count + 1 .Sheets("total").Range("A" & LR).PasteSpecial xlPasteValues .Save .Close End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي

أخي الفاضل صلاح الدين أبو حسين أهلا ومرحبا بك في المنتدى ... نزلت أهلاً وحللت سهلاً ونورت بين إخوانك .. إن شاء الله تستفيد من إخوانك بالمنتدى أولاً : خلاص كفاية ترحيب وندخل في المفيد ثانيا : الكود بتاعك مش عاجبني (أيوا مش عاجبني !! عندك مااااااانع .. اعترض لو تقدر) ثالثاً : الأخطاء في الكود ببساطة كالتالي 1 - الخطأ الأول في السطر Workbooks.Open Filename:="d:\z.xls" هذا هو الشكل الصحيح حيث أنك نسيت علامة \ في مسار الملف .. ويجب ألا تنسى أن يكون الملف في نفس المسار المذكور أي أن المصنف المسمى z.xls يجب أن يكون على البارتشن C 2- حضرتك في الكود في الجزء اللي بعد علامة يساوي كاتب اسم المصنف "برنامج العمل" ودا مش حااااصل لأن المصنف اسمه "تفاصيل" وورقة العمل المطلوب العمل عليها اسمها بردو "تفاصيل" فالشكل الصحيح للكود يجب أن يكون كالتاااااااالي : Sub ss() Sheets("تفاصيل").Select MM = Range("Q1").Value Workbooks.Open Filename:="d:\z.xls" Workbooks("z").Sheets("total").Range("a2:p1000").ClearContents lastr = Workbooks("z").Sheets("total").Range("A1").CurrentRegion.Rows.Count For pp = 1 To (MM) Workbooks("z").Sheets("total").Cells(lastr + pp, 1) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 1) Workbooks("z").Sheets("total").Cells(lastr + pp, 5) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 5) Workbooks("z").Sheets("total").Cells(lastr + pp, 4) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 4) Workbooks("z").Sheets("total").Cells(lastr + pp, 6) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 6) Workbooks("z").Sheets("total").Cells(lastr + pp, 3) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 3) Workbooks("z").Sheets("total").Cells(lastr + pp, 2) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 2) Workbooks("z").Sheets("total").Cells(lastr + pp, 7) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 7) Workbooks("z").Sheets("total").Cells(lastr + pp, 8) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 8) Workbooks("z").Sheets("total").Cells(lastr + pp, 9) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 9) Workbooks("z").Sheets("total").Cells(lastr + pp, 10) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 10) Workbooks("z").Sheets("total").Cells(lastr + pp, 11) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 11) Workbooks("z").Sheets("total").Cells(lastr + pp, 12) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 12) Workbooks("z").Sheets("total").Cells(lastr + pp, 13) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 13) Workbooks("z").Sheets("total").Cells(lastr + pp, 14) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 14) Workbooks("z").Sheets("total").Cells(lastr + pp, 15) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 15) Workbooks("z").Sheets("total").Cells(lastr + pp, 16) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 16) 'Workbooks("work").Sheets("total").Cells(lastr + pp, 1) = lastr + pp Next Workbooks("z").Save Workbooks("z").Close End Sub شوية أورجع لك بكود يؤدي نفس الغرض بأقل مجهود وبدون كل اللف الموجود