מאקרו רץ בלולאה

[one1010]

אקדים שאני לא מבין בכלל בVBA
אני מנסה להריץ מאקרו באקסל, הבעיה היא שכשאני מריץ הוא לא גומר לרוץ וכל פעם מופיע לי התוצאה שחיפשתי ללא דרך להפסיק את זה עד כיבוי כפוי של הקובץ.
איך הדרך הכי פשוטה לגרום לו לפעול רק פעם אחת לפי בקשה?

תודה רבה

[ארי]

@one1010 ממש שאלה קשה...
היא עוד יותר קשה כשאנחנו לא יודעים מה הקוד...
אתה יכול לצרף אותו גדי שנוכל לנסות לעזור לך?

[one1010]

@ארי הקוד אמור למצוא בלוח שנה 3 תאריכים רצופים צבועים בצהוב

[ארי]

@one1010 אתה יכול לכתוב כאן את הקוד?
כנראה חסר לו מה שיעצור אותו, אבל בלי לראות את הקוד עצמו אי אפשר לעזור...

[one1010]

@ארי

Private Sub Workbook_Open()

Sub FindCycles()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim date1 As Date
    Dim date2 As Date
    Dim date3 As Date
    Dim rangeToCheck As Range
    
    Set rangeToCheck = Range("B12:AG12")
    
    For i = 1 To rangeToCheck.Count - 2
        For j = i + 1 To rangeToCheck.Count - 1
            For k = j + 1 To rangeToCheck.Count
                date1 = rangeToCheck.Cells(i).Value
                date2 = rangeToCheck.Cells(j).Value
                date3 = rangeToCheck.Cells(k).Value
                
                If date1 = date2 And date2 = date3 Then
                    MsgBox "Found a cycle of 3 identical dates: " & date1
                ElseIf DateDiff("d", date1, date2) = DateDiff("d", date2, date3) And DateDiff("d", date1, date2) > 0 Then
                    MsgBox "Found a cycle of 3 dates with equal time differences: " & date1 & ", " & date2 & ", " & date3
                End If
                
            Next k
        Next j
    Next i
    
    ' החלק הבא יכול להיות מוסיף חפיפות לפי המחזוריות
    
End Sub

[ארי]

@one1010 שתי הערות בקוד הנ"ל.

1. האם הוא צריך למצוא רק תאריכים רצופים כמו שכתבת? כי זה נראה שהוא מוצא גם אם הם לא רצופים (וגם בלי קשר לצבע שלהם).
2. הבעיה שלו זה שגם אם הוא מוצא שלוש שדות ריקות הוא מתייחס לזה שהם שווים, צריך להוסיף לו תנאי שאם שלושתם ריקים שיתעלם.

בשביל לפתור את זה שהוא רץ לנצח (אגב, לא לנצח אלא עד שגומר לרוץ על כל הטווח שמוגדר לו) צריך לשנות את השורה הזו:

                If date1 = date2 And date2 = date3 Then

לזה:

If date1 = date2 And date2 = date3 And date1 <> "00:00:00" And date2 <> "00:00:00" And date3 <> "00:00:00" Then

וככה אם השדות ריקות הוא יתעלם מהם.

[one1010]

@ארי דבר ראשון תודה!
לעצם מה שכתבת, עד עכשיו הוא כן חישב רק את מה שצבוע בצהוב.
באמת עזר שינוי הקוד והוא לא מחשב עכשיו שדות ריקות.
מה שכן, עד עכשיו הוא חישב לי 3 תאריכים שווים מסומנים [15.01 15.02 15.03] עכשיו פתאום הוא הגיע לתוצאה מוזרה: 15.01 15.02 18.03

יש לך הסבר לזה?

ולגבי הלולאה, זה עדיין לא עזר, מופיע לי הודעה עם התוצאה וכל פעם שאני לוחץ עליה אישור היא קופצת מחדש...

אשמח לעזרה!!
תודה רבה!

[ארי]

@one1010 כתב במאקרו רץ בלולאה:

לעצם מה שכתבת, עד עכשיו הוא כן חישב רק את מה שצבוע בצהוב.

לא אמור להיות קשר לקוד, הוא רץ על לולאה בלי קשר לצבע.

לגבי התאריכים, זה קשור לזה שבחודש 2 יש רק 28 יום, וממילא בין ה15/1 עד ל15/2 יש 31 יום, וגם בין ה15/2 ל18/3 יש 31 ימים.

בלולאה, איזה הודעה הוא מקפיץ לך? את אותה ההודעה?אולי יש לך קובץ דוגמא, כי לי בקובץ דוגמא שעשיתי זה עובד מצוין. מצרף דוגמא.

לולאה על טווח תאריכים.xlsm

[one1010]

@ארי כתב במאקרו רץ בלולאה:

איזה הודעה הוא מקפיץ לך?

זאת:

[ארי]

@one1010 כתב במאקרו רץ בלולאה:

@ארי כתב במאקרו רץ בלולאה:

איזה הודעה הוא מקפיץ לך?

זאת:

וכשאתה לוחץ אישור הוא מציג אותה שוב?

[one1010]

@ארי כתב במאקרו רץ בלולאה:

לא אמור להיות קשר לקוד, הוא רץ על לולאה בלי קשר לצבע.

עכשיו אני מבין הכל!!
זה באמת לא מתייחס לצבע ולכן כל פעם שאני לוחץ אישור זאת לא אותה הודעה אלא הודעה חדשה על רצף חדש של תאריכים...

[ארי]

@one1010 אכן כך.
רק שים לב כמו שכתבתי למעלה שהוא מציג גם תאריכים לא צמודים.

[one1010]

@ארי כתב במאקרו רץ בלולאה:

@one1010 אכן כך.

יש פתרון?!

עשיתי את הקוד הבא, אבל הוא כותב לי שלא נמצאו תאים...

Sub SumYellowCells()
Dim rng As Range
Dim cell As Range
Dim sum As Double

Set rng = Range("A7:AG355") '

For Each cell In rng.SpecialCells(xlCellTypeConstants, 2).Cells
    If cell.DisplayFormat.Interior.Color = RGB(255, 255, 0) Then ' זיהוי תאים מודגשים בצהוב
        If cell.HasFormula Then ' בדיקה אם התא הנוכחי הוא מחזורי
            If InStr(1, cell.Formula, "SUM(") = 0 Then ' בדיקה אם התא הוא מסכם עצמאי
                sum = sum + cell.Value
            End If
        End If
    End If
Next cell

MsgBox "The sum of yellow cells that are not circular references is: " & sum

End Sub

רק שים לב כמו שכתבתי למעלה שהוא מציג גם תאריכים לא צמודים.

כמו איזה?

[ארי]

@one1010 מה אתה מנסה לכתוב? שהוא יעבור בלולאה רק על התאים שאתה בוחר?
תאריכים לא צמודים כוונתי הייתה שאם לדוג' בתא B12 יש תאריך ובתאים D12 וF12 יש אותו תאריך הוא יודיע עליו, ולאו דוקא בתאים צמודים זל"ז.

[one1010]

@ארי כתב במאקרו רץ בלולאה:

@one1010 מה אתה מנסה לכתוב? שהוא יעבור בלולאה רק על התאים שאתה בוחר?

לא בלולאה, אלא שיחפש מחזוריות בתאים צבועים מתוך כל הגליון

תאריכים לא צמודים כוונתי הייתה שאם לדוג' בתא B12 יש תאריך ובתאים D12 וF12 יש אותו תאריך הוא יודיע עליו, ולאו דוקא בתאים צמודים זל"ז.

אני לא רוצה שיזהה 15-18 לחודש הראשון אלא מחזוריות בחודשים נפרדים. כמו 15 לחודש בראשון ובשני ובשלישי וגם 15 בראשון 16 בשני ו17 בשלישי

[ארי]

@one1010 הקוד הזה עובד לך?

Sub SumYellowCells()
Dim rng As Range
Dim cell As Range
Dim sum As Double

Set rng = Range("A7:AG355")

For i = 1 To rng.Count
    If rng.Cells(i).Interior.Color = RGB(255, 255, 0) Then
        If rng.Cells(i).HasFormula = False Then
            If InStr(1, rng.Cells(i).Formula, "SUM(") = 0 Then
                sum = sum + rng.Cells(i).Value
            End If
        End If
    End If
Next i

MsgBox "The sum of yellow cells that are not circular references is: " & sum
End Sub

הוא אמור לעבור בלולאה על כל התאים בצבע צהוב (בטווח שבין A7 לAG355) ולסכם אותם (בתנאי שהם לא נוסחה ולא סיכום).

משום מה נראה לי שהקוד שהבאת בתחילת השרשור לא קשור לקוד שאתה צריך...
הקוד ההוא עובר בלולאה (בשביל לבדוק כמה תאים חייבת להיות לולאה שעוברת עליהם) ואם הוא מוצא שלושה תאים עם אותו תאריך הוא מקפיץ הודעה, וכן אם הוא מוצא שלושה תאריכים שיש ביניהם אותו הבדל של ימים גם כן מקפיץ הודעה.
איך זה קשור לקוד שהבאת מקודם שמסכם את כל התאים בצהוב?

@one1010 כתב במאקרו רץ בלולאה:

וגם 15 בראשון 16 בשני ו17 בשלישי

נראה לי שבשביל זה אתה צריך משהו יותר מתוחכם ממה שאני יודע....

[dovid]

@one1010 סתם שאלה, מי כתב לך את הקוד הראשון?

[OdedDvir]

@one1010 כתב במאקרו רץ בלולאה:

For i = 1 To rangeToCheck.Count - 2
For j = i + 1 To rangeToCheck.Count - 1
For k = j + 1 To rangeToCheck.Count

1. השורות האלו גורמות לי צמרמורת...לכאורה יש כאן חוסר יעילות גדול בכמות הבדיקות שנעשית.
2. אני מודה שלא התעמקתי בכל השרשור, וממילא לא הבנתי מה בדיוק הבדיקה, אבל אני מוכן לעזור לך אם תפרט בדיוק מה אתה רוצה שהקוד יעשה, מא' ועד ת'.

[one1010]

@dovid כתב במאקרו רץ בלולאה:

@one1010 סתם שאלה, מי כתב לך את הקוד הראשון?

נראה לי שאתה יודע את התשובה...

[one1010]

@OdedDvir כתב במאקרו רץ בלולאה:

אני מודה שלא התעמקתי בכל השרשור, וממילא לא הבנתי מה בדיוק הבדיקה, אבל אני מוכן לעזור לך אם תפרט בדיוק מה אתה רוצה שהקוד יעשה, מא' ועד ת'.

הקוד שאני רוצה הוא לכאורה מאד ארוך, לכן זה יהיה מוגזם שתעזור לי בהכל....
אבל אולי שלב שלב...
אני רוצה קוד שיזהה תאריכים מסומנים בצהוב ובמידה וביניהם יש מחזוריות מסויימת שחוזרת על עצמה 3 פעמים שיסמן אותם.
לדוגמא 15.01 15.02 15.03
וגם 15.01 16.02 17.03
וכן עוד כאלו בסגנון הזה