השוואה בין שתי טבלאות אקסל

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

אך בפוסט זה אני רוצה להראות דוקא את הדרך הארוכה באמצעות קוד VBA משתי סיבות :

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

לאחר שהכנו לו פונקציית VBA יעודית לצרכיו.

2.בקוד VBA שאציג ניתן ללמוד מספר פקודות VBA נוספות,

וכך מי שמעוניין יוכל ללמוד יותר על כתיבת קוד VBA.

לצורך ההדגמה יצרתי גיליון אקסל עם 2 עמודות של שמות אנשים, ונרצה

למצוא את הכפילות בין העמודה הראשונה לשניה.

עמודה B היא רשימת העובדים, בעמודה D יש רשימה נוספת של עובדים בעמודה E8 מזינים את העמודה הראשונה שרוצים לבדוק ובעמודה E10 מזינים את העמודה בה נחפש כפילויות

וחזרה על השמות שבעמודה שנקרא לה עמודת המקור.

עלינו לכתוב 2 לולאות, אחת שרצה על כל השמות שבעמודה

B ושניה שמחפשת את כל הכפילויות לשורה הנוכחית בעמודה D.

נשתמש בפונקציות FIND ו FIND NEXT על מנת למצוא את הכפילויות.

FIND מקבלת מה אנחנו מחפשים ובאיזה טווח של עמודות ורשומות ומוצאת את המופע הראשון

של ההתאמה במידה וקיים.

FIND NEXT תמצא את כל השאר הכפילויות במידה וקיימות. הלולאה תסתיים

כאשר נגיע שוב לתוצאה הראשונה.

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

לדוגמא DANI LEVI מופיע ב B6 ויש לו כפילות ב D8 אז ב F8 ירשם D8.

הנה הקוד המלא מאחורי הכפתור "מצא כפילויות"

Sub Button1_Click()
Dim whatwelookingfor As String
Dim ws As Worksheet: Set ws = Sheets("book1")
Dim marks As String
Dim FirstRow As Integer
Dim FindRowNumber As Long
Dim FindRow As Range
Dim myrange As Range: Set myrange = ws.Range("A1:C100")
Dim cellNum As Variant
Dim firstline As Integer: firstline = 0
Dim leftcol As String
Dim rightcol As String
Dim s1 As OLEObject

' Clean output from last search
'—————————
Columns("F:F").Select
Selection.ClearContents
i = 3

'Get cols 2 cpmpare
'——————

leftcol = Range("E8:E8").Text
rightcol = Range("E10:E10").Text

'Erase the color from last search
'——————————-
Range(rightcol & "2:" & rightcol & "47").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With

'Loop all source column lines
'——————————–
Do While ws.Range(leftcol & Trim(Str(i)) & ":" & leftcol & Trim(Str(i))).Text <> ""

whatwelookingfor = Range(leftcol & Trim(Str(i) & ":" & leftcol & Trim(Str(i)))).Text

' find first match
'——————
Set s1 = ActiveSheet.OLEObjects("CheckBox1")
If s1.Object.Value Then
Set FindRow = ws.Range(rightcol & ":" & rightcol).Find(What:=whatwelookingfor, LookIn:=xlValues, lookat:=xlWhole)
Else
Set FindRow = ws.Range(rightcol & ":" & rightcol).Find(What:=whatwelookingfor, LookIn:=xlValues, lookat:=xlPart)
End If
firstline = 0
If Not FindRow Is Nothing Then

FindRowNumber = FindRow.Row
If firstline = 0 Then firstline = FindRow.Row

Do ' look for all the rest of duplicats
'——————————–

lastline = FindRow.Row

Set FindRow = ws.Range(rightcol & ":" & rightcol).FindNext(FindRow)
If Not FindRow Is Nothing Then
FindRowNumber = FindRow.Row

'Update col f with the duplicated col location
'———————————————
ws.Range("F" & Trim(Str(i)) & ":F" & Trim(Str(i))) = ws.Range("F" & Trim(Str(i)) & ":F" & Trim(Str(i))) & IIf(ws.Range("F" & Trim(Str(i)) & ":F" & Trim(Str(i))) = "", Trim(rightcol), ",") & Trim(FindRow.Row)
'Color the duplicated col
'————————
With ws.Range(rightcol & Trim(Str(FindRowNumber)) & ":" & rightcol & Trim(Str(FindRowNumber))).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
.ThemeColor = xlThemeColorAccent1
End With

End If
Loop While FindRowNumber <> firstline And Not FindRow Is Nothing And lastline <> FindRow.Row

Else

'In case that no matches fround for this sorce col
'————————————————
ws.Range("F" & Trim(Str(i)) & ":F" & Trim(Str(i))) = "àéï ëôéìåéåú"

With ws.Range(rightcol & Trim(Str(i)) & ":" & rightcol & Trim(Str(i))).Interior

.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With

End If
i = i + 1

Loop

End Sub

'24
' Set myTableArray = .Range(.Cells(myFirstRow, myFirstColumn), .Cells(myLastRow, myLastColumn))

Sub Macro1()
'
' Macro1 Macro
'

'
Cells.Find(What:="S/W Nurses", After:=ActiveCell, LookIn:=xlFormulas, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
End Sub

הנה התוצאה המתקבלת לאחר הפעלת החיפוש

כפי שניתן לראות הוספתי גם צ'קבוקס לבחירה האם אנו רוצים למצוא רק התאמות מדויקות או גם חלקיות

זה מתאפשר ע"י הפרמטר שהכנסנו בפקודת החיפוש: lookat:=xlWhole האומר לחפש רק התאמה מדויקת לעומת

lookat:=xlPart שמאפשר מציאת התאמה חלקית.

הנה התוצאות, כאשר סימנו את הצ'קבוקס נמצאו פחות כפילויות: