دليل وظائف LOOP

[أبو حنــــين]

منذ ساعه, الزباري said:

حيث أن الكود السابق هو:

وكل ما يمكنك التفكير به هو تغيير الكود بداخل المستطيل الأحمر

في هذه الحالة  علينا ان نحذف السطر  :  Range("a1").Select

و نضع مكانه السطر  : ActiveSheet.UsedRange.Select

[الزباري]

 

سأزيد المسألة تعقيداً.. انتظر السؤال التالي.

لو كان للجدول عنوان ، ويوجد فراغ بينه وبين الجدول، فكيف سنطبق الكود؟  (شاهد الجدول التالي)

[الزباري]

الإجابة في هذا الكود:

Cells.Find("name").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
If ActiveCell.Offset(0, 1).Value = "student" Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20
End If
ActiveCell.Offset(1, 0).Select
Loop

 

لاحظ أننا استفدنا من عناوين الجدول للتعرف عليه

في 10/27/2016 at 23:11, سليم حاصبيا said:

اسمحوا لي بهذا الكود

Sub tlween1()

Range("a1").CurrentRegion.Interior.ColorIndex = xlNone
Cells(1, 1).Activate
    Do While ActiveCell <> ""
       If ActiveCell.Offset(0, 1) = "student" Then _
       ActiveCell.Resize(1, 3).Interior.ColorIndex = 4
       ActiveCell.Offset(1, 0).Activate
     Loop
End Sub

تم ادراج اول سطر بالكود لاعادة اللون السابق في حال انتقلت كلمة Student من صف الى اخر

ملاحظة اخرى:

ماذا لو كتبت كلمة student بهذا الشكل  StuDent أو sTuDEnt  أو غيره

سؤال لعشاق ال VBA

 

أعتقد بأن الدالة find تبحث على الإسم بجميع صيغه.

وتقبل تحياتي

[الزباري]

15 ساعات مضت, سليم حاصبيا said:

موضوع اخر خطر على بالي

كيف نحول جدول من شكل الى اخر

انظر الى المرفق

ملاحظة(الكود فيما بعد)

 

for VBA lovers.rar

سؤالنا التالي: سؤال تحدي من أستاذنا سليم حاصبيا.. وبها فكرتين، الأولى العد التنازلي، والثانية الدمج.. بانتظار الإجابة

[الزباري]

اسمحلي بهذه الإجابة

Dim i As Integer
Dim j As Integer
j = 0
Do
j = j + 1
Loop Until Cells(j, 2).Value = ""

For i = j - 2 To 1 Step -1
     If Cells(i + 1, 1) = "" Then Range(Cells(i, 1), Cells(i + 1, 1)).Merge
Next i

طبعاً ينقصها التنسيق..

[أبو حنــــين]

و لإثراء الحلول هذه طريقة أخرى تؤدي نفس العمل

Sub Test5()

Application.ScreenUpdating = False
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If Not Cells(i, 1) = "" Then
        x = Range("A" & i).Row: GoTo 200: End If
        If Cells(i, 1) = "" Then
        xx = Range("A" & i).Row: GoTo 100: End If
100
        With Range(Cells(x, 1), Cells(xx, 1))
       .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
200
    Next
Application.ScreenUpdating = True

End Sub

 

[سليم حاصبيا]

1 ساعه مضت, أبو حنــــين said:

و لإثراء الحلول هذه طريقة أخرى تؤدي نفس العمل

Sub Test5()

Application.ScreenUpdating = False
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If Not Cells(i, 1) = "" Then
        x = Range("A" & i).Row: GoTo 200: End If
        If Cells(i, 1) = "" Then
        xx = Range("A" & i).Row: GoTo 100: End If
100
        With Range(Cells(x, 1), Cells(xx, 1))
       .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
200
    Next
Application.ScreenUpdating = True

End Sub

 

حل ممتاز 

لكن الاخ الزباري يريدها عن طريق Loop

[سليم حاصبيا]

بالاضافة الى حل الاخ ابو حنين (For Next)

حلين اخرين 

1-بواسطة Loop

2-بواسطة Array

for VBA lovers Two In One.rar

[أبو حنــــين]

15 دقائق مضت, سليم حاصبيا said:

حل ممتاز 

لكن الاخ الزباري يريدها عن طريق Loop

إنني وقعت في نفس الذي وقعت فيه أنت سابقا حينما اجبت عن السؤال و قلت لك يومها ان  الاخ الزباري يريدها عن طريق Loop

كما تدين تدان

الان, سليم حاصبيا said:

بالاضافة الى حل الاخ ابو حنين (For Next)

حلين اخرين 

1-بواسطة Loop

2-بواسطة Array

for VBA lovers Two In One.rar

الحل الجميل و الذي اعجبني هو عن طريق  Array

[الزباري]

هههههه.. هذه بتلك 

وكل حل أفضل من الثاني

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

وتقبلوا تحياتي

[توكل]

طبعاً نحن المستفيدون الأكبر من تلاقح هذه الأفكار

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

[الزباري]

الأخ/ توكل  المحترم

أشكر اهتمامك في الموضوع

وعاوزين منك انه تروينا من الكراسة العجيبة الكود الذي يرتب الأرقم من 1 إلى 10 ولكن هذه المرة بشكل تنازلي كالشكل التالي:

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

بارك الله فيك أخي الحبيب الزباري على هذا الموضوع الجميل والمفيد

آخر سؤال : اقلب الحلقة واستخدم كلمة Step -1 لأننا ماشيين بالمقلوب ، زي ما الدنيا كلها ماشية بالمقلوب

تقبل صباحي

[الزباري]

صباح الخير أ.ياسر

الكود تبعك خلاها تمشي عدل

في جزئية بسيطة ويكون الكود صحيح وتمشي بالمقلوب

وتقبل تحياتي

تم تعديل أكتوبر 30, 2016 بواسطه الزباري

[سليم حاصبيا]

جرب هذا الكود

Sub Makloub()
i = 1
answer = Application.InputBox("type yourNumber", "Salim you ask", 5)
 t = Abs(Val(answer))
                If t = 0 Then GoTo 1
With ActiveCell
      .Value = "number from" & Chr(10) & t & " to " & 1
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlCenter
       .Offset(1, 0).Resize(500, 1).ClearContents
End With
    Do Until i > t
     ActiveCell.Offset(t - i + 1, 0) = i
     i = i + 1
     Loop
     Exit Sub
1:
     MsgBox "You must type  a Positive number"
     
End Sub

 

[توكل]

1 ساعه مضت, الزباري said:

الأخ/ توكل  المحترم

أشكر اهتمامك في الموضوع

وعاوزين منك انه تروينا من الكراسة العجيبة الكود الذي يرتب الأرقم من 1 إلى 10 ولكن هذه المرة بشكل تنازلي كالشكل التالي:

أعتقد أن الكود البسيط هذا يحقق المطلوب

Sub z_to_a()
    Dim i As Integer
For i = 1 To 10
x = 11
   Cells(i, 1) = x - i
 Next i
End Sub

 

[سليم حاصبيا]

32 دقائق مضت, توكل said:

أعتقد أن الكود البسيط هذا يحقق المطلوب

Sub z_to_a()
    Dim i As Integer
For i = 1 To 10
x = 11
   Cells(i, 1) = x - i
 Next i
End Sub

 

ممتاز

لكن حبذا عدم التقيد بالرقم 10 ودع المستخدم يختار الرقم الذي يريده

[جلال الجمال_ابو أدهم]

 

أبو حنــــين

سليم حاصبيا

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

الزباري

الاخوه الافاضل ما شاء الله عليكوا
تحياتى

 

[الزباري]

الهدف من هذا المثال توضيح بأن الكود التالي يحقق نفس النتيجة:

Dim i As Integer
    For i = 10 To 1 Step -1
    x = 11
    Cells(i, 1) = x - i
 Next i

حيث أنه لما قلبنا الحلقة واستخدما step-1 لم تقلب النتيجة ، ولكنها بدأت من الصف الأخير إلى الأول

[توكل]

54 دقائق مضت, سليم حاصبيا said:

ممتاز

لكن حبذا عدم التقيد بالرقم 10 ودع المستخدم يختار الرقم الذي يريده

أخي سليم يمكن للكود التالي أن يجيب على سؤالك

Sub z_to_a()
    Dim i As Integer
    answer = Application.InputBox("type yourNumber")
 x = Abs(Val(answer))
For i = 1 To x
x = Abs(Val(answer))
   Cells(i, 1) = x + 1 - i
 Next i
End Sub

 

[الزباري]

بصراحة أشكركم على التفاعل البناء، وكنت أنوي أن أُنهي هذه الحلقة، لكني سأسترسل في أمثلة في غاية الأهمية، فلو لاحظتم بأن دالة Loop تختصر الكودات الكثيرة مقارنة بغيرها، وفي الحقيقة أنا لست خبيراً بها، ولكنني بحثت عنها وتعمقت في فهمها،  وجمعت خلاصة ما تعلمته في هذا المنتدى من خلال أمثلة واقعية تكون بمثابة مرجع لأعمالكم، نفعني الله وإياكم لكل خير.

ترقبوا سؤالنا التالي

[مختار حسين محمود]

 

   بارك الله فيك أخى الزيارى وفى وقتك وجهدك  موضوع رائع ومفيد لكل محبى الفيجوال بيزك

تحياتى

[الزباري]

سؤال التحدي لهذا اليوم:

ما هو الكود الذي يظلل الصفوف بحسب الأشهر الفردية بمعنى يظلل شهر ويترك شهر، كما في المثال التالي:

[سليم حاصبيا]

7 دقائق مضت, الزباري said:

سؤال التحدي لهذا اليوم:

ما هو الكود الذي يظلل الصفوف بحسب الأشهر الفردية بمعنى يظلل شهر ويترك شهر، كما في المثال التالي:

رجاءً ارفع الملف نفسه وليس صورة 

و ذلك للتعامل معه بشكل افضل

ربما الحالة هذه ليس بحاجة الى كود

يكفي النتسيق الشرطي  (مرفق مثال)

Talween_Month.rar

[الزباري]

شكراً على المرفق، التنسيق الشرطي خارج موضوعنا ، نريد أن نتعامل مع دالة Loop، تفضل المرفق:

dt.rar

 

وتقبل تحياتي القلبية