אקסל פרוצדורה ב-VBA לחיפוש כל המופעים של טקסט בחוברת העבודה וסכימת הערכים בתאים הסמוכים לטקסט

מ' שואלת:

שלום לכולם,

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

לדוגמה: בכל מקום בקובץ שכתוב "קורונה" נדרש לסכום את סך המספרים שליד המילה. אם בקובץ מופיעים הערכים - קורונה 10, קורונה 20 הנוסחה תחזיר את הערך 30.

 

תודה רבה

תשובה:

מצ"ב הצעה לפיתרון -

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

מצ"ב הצעה לפתרון על ידי שימוש בקוד VBA -

1. בגיליון אקסל נגדיר במספר תאים את הערך "קורונה" ובתאים הסמוכים ערכים מספריים. לדוגמא:

 

2. נפתח את עורך VBA של אקסל על ידי לחיצה על Alt+F11, נסמן את Microsoft Excel Objects ונבחר ב-Insert Module.

 

3. נסמן את Module1 ונבחר ב-View Code.

 

 

4. נעתיק ונדביק את הקוד הבא לאקסל -

הקוד כולל את הפוקציה Find_All שמקבלת כפרמטרים טווח לחיפוש נתונים ומילה לחיפוש ומחזירה את כתובות התאים בהם נמצאה המילה.

ואת הפרוצדורה Total_Corona שסוכמת את הערכים המופיעים ליד המילה "קורונה" בכל הגיליונות בחוברת העבודה.

הפרוצדורה עוברת על כל הגיליונות בחוברת העבודה.

עבור כל גיליון מבוצעת קריאה לפונקציה Find_All  המחזירה את כתובות התאים בגיליון בהם נמצאה המילה "קורונה".

במידה המילה "קורונה" נמצאה בגיליון - מבוצע מעבר על התאים בהם נהיא נמצאה ומבוצעת סכימה של הערכים בתאים הסמוכים.

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

 

 

Public Sub Total_Corona()

Dim wSh As Worksheet, rngFoundCells As Range, cell As Range, dblTotal As Double

For Each wSh In ThisWorkbook.Worksheets
    Set rngFoundCells = Find_All(wSh.UsedRange, "קורונה")
    If Not rngFoundCells Is Nothing Then
        For Each rngCell In rngFoundCells
            dblTotal = dblTotal + rngCell.Offset(0, 1).Value
        Next rngCell
    End If
Next wSh

MsgBox "סך קורונה " & dblTotal, vbInformation

End Sub

Public Function Find_All(ByVal rng As Range, ByVal searchTxt As String) As Range

Dim foundCell As Range, firstAddress As String, rResult As Range

    With rng
        Set foundCell = .Find(What:=searchTxt, _
                              After:=.Cells(.Cells.Count), _
                              LookIn:=xlValues, _
                              LookAt:=xlWhole, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlNext, _
                              MatchCase:=False)
        If Not foundCell Is Nothing Then
            firstAddress = foundCell.Address
            Do
                If rResult Is Nothing Then
                    Set rResult = foundCell
                Else
                    Set rResult = Union(rResult, foundCell)
                End If
                Set foundCell = .FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
        End If
    End With

    Set Find_All = rResult
End Function

 

 

 6 נחזור לגיליון האקסל ונלחץ על Alt + F8 ונבחר במקרו Total_Corona ונלחץ על Run.

 

5. התוצאה -

 

 

 

בברכה,

צוות AnyFit