دليل وظائف LOOP

[الزباري]

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

Dim i As Date
Range("a1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
For j = 1 To 12 Step 2
i = ActiveCell.Offset(0, 0).Value
If Month(i) = j Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20
End If
Next j
ActiveCell.Offset(1, 0).Select
Loop

المرفق:

color odd month loop.rar

 

 

 

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

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

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

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

Dim i As Date
Range("a1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
For j = 1 To 12 Step 2
i = ActiveCell.Offset(0, 0).Value
If Month(i) = j Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20
End If
Next j
ActiveCell.Offset(1, 0).Select
Loop

المرفق:

color odd month loop.rar

 

 

 

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

تعديل بسيط على الكود (يجعله اسرع)

مجرد ان يتم التلوين نخرح من Loop ليست هناك حاجة لتكملتها الى الرقم 12 

Sub Rectangle1_Click()
Dim i As Date
Range("a1:c500").Interior.ColorIndex = xlNone
Range("a2").Select
Do Until ActiveCell.Value = ""
For j = 1 To 12 Step 2
i = ActiveCell.Offset(0, 0).Value
        If Month(i) = j Then
                Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20
                Exit For ' add this very small line to the code
        End If
Next j
ActiveCell.Offset(1, 0).Select
Loop
End Sub

 

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

اليكم هذا الكود (لرسم خط النهاية مع التلوين)

لم اتقيد بعرض الاعمدة لانها اصبحت من الامور المعروفة

Sub talween()
Dim i As Date, k,lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(3).Row
Range("a1:c" & lastrow).Interior.ColorIndex = xlNone
Range("a1:c" & lastrow).Borders.LineStyle = xlNone
k = 2

Do Until k > lastrow + 1
 If Month(Range("a" & k)) Mod 2 = 1 Then
    Range(Cells(k, 1), Cells(k, 3)).Interior.ColorIndex = 20
       If Month(Cells(k, 1)) <> Month(Cells(k + 1, 1)) Then
           Range(Cells(k, 1), Cells(k, 3)).Borders(xlEdgeBottom).LineStyle = xlContinuous
       End If
 End If
  k = k + 1
Loop
End Sub

 

[saad abed]

اخى الزبارى

 جزاك الله خيرا وبارك الله فى صحتك ووقتك

اسال الله العظيم ان يزيدك من العلم

من افضل المواضيع منذ نشاة المنتدى وانا قديم منذ نشاته

فكل من شرح ولهم الشكر فقد شرحوا الكلمات والالفاظ البرمجيه

معنى حلقة دوران ---------- الالفاظ المستخدمه ----------وترتيب الجمل

لكن اخى الزبارى له اسلوب جديد هو كل ماسبق وزياده عليه الية استخدام الحلقات والامثله التى من الممكن ان تخطر ببال المستخدم

متابعين بشغف الله الله********************************************

[الزباري]

منور تواجدك يا أ.سعد عابد

 

شاكرين لك أ.سليم حاصبيا، وبصراحة you are lovely vba

ولتحقيق مزيد من الديناميكية إليك هذا الكود:

Dim i As Date
Dim j As Date

Range("a1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
i = ActiveCell.Offset(0, 0).Value
j = ActiveCell.Offset(1, 0).Value
If Month(i) = Month(j) - 1 Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlThin
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlThin
ActiveCell.Offset(1, 0).Select

المرفق:

line end month loop.rar

إلى هنا ينتهي الفصل قبل الأخير، ونراكم في الفصل الأخير غداً بإذن الله تعالى

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

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

منور تواجدك يا أ.سعد عابد

 

شاكرين لك أ.سليم حاصبيا، وبصراحة you are lovely vba

ولتحقيق مزيد من الديناميكية إليك هذا الكود:

Dim i As Date
Dim j As Date

Range("a1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
i = ActiveCell.Offset(0, 0).Value
j = ActiveCell.Offset(1, 0).Value
If Month(i) = Month(j) - 1 Then
Range(ActiveCell, ActiveCell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlThin
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlThin
ActiveCell.Offset(1, 0).Select

المرفق:

line end month loop.rar

انا لا افهم ما الحاجة الى كتابة هذين السطرين

Range("a1").Select
ActiveCell.Offset(1, 0).Select

ما دام تسطيع ان تستبدلها بكلمتين

Range("a2").Select

 

[الزباري]

كلامك صحيح أستاذي

[الزباري]

الفصل الأخير

سأخصص هذا الفصل في القراءة التحليلية للكود، وخير من شرح هذا الموضوع صاحب هذا الموقع في دراسة تحليلية للغة php ، إلا أننا استفدنا منها في تحويلها إلى لغة vba.

 

المثال الأول:

ما هو الكود الذي يحقق النتيجة التالية:

 

التحليل:

 

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

For i = 1 To 5
    For j = 1 To i
    Cells(i, j) = j
    Next j
Next i

 

[الزباري]

واختصاراً للوقت

هذا مرفق لأمثلة أخرى :

loops example.rar

 

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

[توكل]

جزاك الله خيراً وجعل ذلك في صحائف حسناتك وصحائف والديك

 

[الزباري]

سؤالنا: ما هو الكود الذي يحقق النتيجة التالية:

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

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

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

سؤالنا: ما هو الكود الذي يحقق النتيجة التالية:

لم تظهر الصورة

[الزباري]

كنت ناوي أغيرها، انظر الآن

سؤالنا: ما هو الكود الذي يحقق النتيجة التالية:

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

نفس المشكلة 

و على ماذا انظر

انظر إلى السؤال السابق فوق

الكود

Sub chang_Symboles()
Range("a1:e5") = "*"
 For i = 1 To 5
  For j = i + 1 To 5
    Cells(i, j) = "-"
    Next
 Next
End Sub

 

[الزباري]

هذه من الطرق التحايلية..

فقد بدأت برسم مربع نجوم، ومن ثم رسمت فوقه مثلث خطوط، أهنيك على الفكرة.

جرب هذا الكود:

For i = 1 To 5
    For k = 1 To 5 - i
    Cells(k, i) = "-"
   Next k
     For j = 1 To 6 - i
    Cells(6 - i, 6 - j) = "*"
     Next j
Next i

وهذا كود بالمقلوب:

For i = 1 To 5
    For k = 1 To i - 1
    Cells(k, i) = "-"
   Next k
     For j = 1 To i
    Cells(i, j) = "*"
     Next j
Next i

 

 

السؤال التالي: ماهو الكود الذي يحقق النتيجة التالية:

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

[الزباري]

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

'طباعة الرمز قبل الحلقة في الخلية أ1
Cells(1, 1) = "*"
For i = 2 To 7
'طباعة الرمز في أول عمود
    Cells(i, 1) = "*"
    For k = 2 To i - 1
    Cells(i, k) = "-"
   Next k
' طباعة الرمز مائل
   Cells(i, k) = "*"
Next i
'طباعة الرمز في الصف الأخير
     For j = 1 To 8
    Cells(i, j) = "*"
      Next j

 

نختم بهذا الملف التي يقوم بالتلوين الشطرنجي:

المرفق:

شطرنجي.rar

[الزباري]

وختاماً

شكرا من القلب واعماقه

لجميع من حضر

وجميع من ساهم بنجاح هذا الموضوع

 

وأخص بالشكر كل من:

morestudy

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

توكل

أبو حنف

زيزو العجوز

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

عمار محمد حسن

محمد حمدان

إبراهيم ابوليله

أبو حنــــين

سليم حاصبيا

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

سعد عابد

 

يجود الخيرون علينا بعلمهم       ونحن بعلم الخيرين نجود

ولا نقول وداعاً ولكن نقول إلى لقاء قريب بإذن الله

 

 

تم تعديل نوفمبر 1, 2016 بواسطه الزباري

[توكل]

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

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

الزباري

اخى الفاضل
ما شاء الله عليك و جزاك الله خيرا
و فى انتظار موضوع اخر

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

ربما هذا الكود يقوم بالمطلوب

Sub sheck()
Range("a1:H8").Interior.ColorIndex = xlNone
For i = 1 To 8
 k = i Mod 2
    For j = 1 To 8
        m = j Mod 2
        If k = m Then Cells(i, j).Interior.Color = 255
     Next
Next
End Sub

 

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

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

وختاماً

شكرا من القلب واعماقه

لجميع من حضر

وجميع من ساهم بنجاح هذا الموضوع

 

وأخص بالشكر كل من:

morestudy

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

توكل

أبو حنف

زيزو العجوز

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

عمار محمد حسن

محمد حمدان

إبراهيم ابوليله

أبو حنــــين

سليم حاصبيا

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

سعد عابد

 

يجود الخيرون علينا بعلمهم       ونحن بعلم الخيرين نجود

ولا نقول وداعاً ولكن نقول إلى لقاء قريب بإذن الله

 

 

بقي هذا الكود للاختيار

Sub sheck()
Range("a1:H8").Interior.ColorIndex = xlNone
For i = 1 To 8
 k = i Mod 2
    For j = 1 To 8
        m = j Mod 2
        If k = m Then Cells(i, j).Interior.Color = 255
     Next
Next
End Sub

 

[محمد حمدان]

الله يعطيكن العافية جميعا .

ويجزيكن الخير .

وان شاء الله نبقى على تواصل دائما .

 

[ليلى الهلالي]

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

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

سليم حاصبيا و الزباري

الاخوه الافاضل مشاركه محترمه كنا نفتقدها منذ فتره طويله

تحياتى