เปรียบเทียบexcel 2 ไฟล์ เพื่อหาความแตกต่างในแต่ละบรรทัด

[kit]

สวัสดีครับ ขอคำแนะนำในการเขียนคำสั่ง VB เพื่อเปรียบเทียบ Excel 2 ไฟล์และหาความแตกต่างในแต่ละบรรทัดทั้ง ROW และ Column เมื่อมีบรรทัดที่แตกต่างจะให้ลงสีเหลืองไว้ครับ ตามภาพประกอบที่แนบมาครับ ขอบคุณครับ

[puriwutpokin]

ตามกฏข้อ5 ต้องเขียนหรือศึกษามาก่อนเบื้องต้นติดตรงไหนมาถามต่อในบอร์ดต่อครับ

[kit]

ตอนนี้ที่ผมเขียนได้คือเช็คความแตกต่างของ 2 column ในชีสเดียวกันครับ ถ้าต้องการเช็คความแตกต่างของ 2 ไฟล์ หลาย column ต้องแก้ไขหรือเพิ่มเติมโค๊ดอย่างไร รบกวนช่วยชี้แนะแนวทางหน่อยครับ ขอบคุณครับ


Sub Format_Result()

Range("C7:C111").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(Data2,C7)=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With

Range("E7:E111").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(Data1,E7)=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With

[puriwutpokin]

คราวหน้าให้โค้ด VBA ให้เป็นโค้ดตามแบบตัวอย่างโค้ดนี้ด้วยครับ
ตัวอย่างโค้ดครับ

Code: Select all

Sub NoMatch()
Dim r1, r2, c1, c2, Ar, Ac1, Ac2 As Range
    Windows("Project1.xlsx").Activate
    Range("B2").Select
    With ThisWorkbook.Sheets("Sheet1")
    Set Ac1 = .Range(.Cells(2, 2), .Cells(2, .Cells(2, .Columns.Count).End(xlToLeft).Column))
    Set Ar1 = .Range("b2:b" & .Cells(.Rows.Count, 2).End(xlUp).Row)
    End With
    Set Ac2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range(Cells(2, 2), Cells(2, Cells(2, Columns.Count).End(xlToLeft).Column))
    Set Ar2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each c1 In Ac1
    If IsError(Application.Match(c1, Ac2, 0)) Then
    c1.Resize(Cells(Rows.Count, 2).End(xlUp).Row + 1).Interior.ColorIndex = 6
End If
    Next c1
    For Each r1 In Ar1
If IsError(Application.Match(r1, Ar2, 0)) Then
    r1.Resize(, Cells(2, Columns.Count).End(xlToLeft).Column).Interior.ColorIndex = 6
    End If
    Next r1
Windows("Project2.xlsm").Activate
End Sub

[kit]

ได้แล้วครับ ขอบคุณมากๆเลยครับ

[kit]

เพิ่มเติมอีกนิดนะครับ ถ้าต้องการเช็คทุก Cell ของ 2 ไฟล์เพื่อหาความแตกต่างแล้วใส่สีเหลืองเอาไว้ ตามไฟล์รูปภาพที่แนบมา ควรจะเพิ่มหรือแก้ไขโค๊ดอย่างไรครับ ขอบคุณครับ

Sub NoMatch()
Dim r1, r2, c1, c2, Ar, Ac1, Ac2 As Range
'Workbooks.Open Filename:="C:\Users\Desktop\Project1.xlsx"
Windows("Project1.xlsx").Activate
Range("B2").Select

With ThisWorkbook.Sheets("Sheet1") ' check project2
Set Ac1 = .Range(.Cells(2, 2), .Cells(2, .Cells(2, .Columns.Count).End(xlToLeft).Column)) 'Check column
Set Ar1 = .Range("b2:b" & .Cells(.Rows.Count, 2).End(xlUp).Row) 'Check Row

End With
' check project1
Set Ac2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range(Cells(2, 2), Cells(2, Cells(2, Columns.Count).End(xlToLeft).Column))
Set Ar2 = Workbooks("Project1.xlsx").Sheets("Sheet1").Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)

For Each c1 In Ac1
If IsError(Application.Match(c1, Ac2, 0)) Then
c1.Resize(Cells(Rows.Count, 2).End(xlUp).Row + 1).Interior.ColorIndex = 6
End If
Next c1

For Each r1 In Ar1
If IsError(Application.Match(r1, Ar2, 0)) Then
r1.Resize(, Cells(2, Columns.Count).End(xlToLeft).Column).Interior.ColorIndex = 6
End If
Next r1
Windows("Project2.xlsm").Activate
End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Dim d1 As Object, d2 As Object, d3 As Object
Dim w1 As Workbook, w2 As Workbook
Dim rAll As Range, r  As Range
Dim rtAll As Range, rt As Range
Dim t As String, s As String
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")

Set w1 = Workbooks("Project1.xlsx")
Set w2 = Workbooks("Project2.xlsx")
With w1.Worksheets(1)
    Set rAll = .Range("b2").CurrentRegion
    For Each r In rAll.Rows(1).Cells
        d1.Add Key:=r.Value, Item:=r.Value
    Next r
    For Each r In rAll.Columns(1).Cells
        d2.Add Key:=r.Value, Item:=r.Value
    Next r
    For Each r In rAll
        If r.Row > 2 And r.Column > 2 Then
            s = r.Parent.Cells(r.Row, 2).Value & "|" & _
                r.Parent.Cells(2, r.Column).Value & "|" & _
                r.Value
            d3.Add Key:=s, Item:=s
        End If
    Next r
End With
With w2.Worksheets(1)
    Set rtAll = .Range("b2").CurrentRegion
    For Each rt In rtAll
        If rt.Row = 2 Then
            If Not d1.Exists(rt.Value) Then
                rt.Interior.Color = rgbYellow
            End If
        ElseIf rt.Column = 2 Then
            If Not d2.Exists(rt.Value) Then
                rt.Interior.Color = rgbYellow
            End If
        Else
            t = rt.Parent.Cells(rt.Row, 2).Value & "|" & _
                rt.Parent.Cells(2, rt.Column).Value & "|" & _
                rt.Value
            If Not d3.Exists(t) Then
                rt.Interior.Color = rgbYellow
            End If
        End If
    Next rt
End With

ในครั้งถัดไป ให้โพสต์ Code ในรูปแบบของอักษรแบบ Code ดูตัวอย่างที่กฎการใช้บอร์ดข้อ 5 ด้านบน เพื่อจะแยกจากข้อความปกติและสะดวกในการคัดลอกไปทดสอบ

[kit]

ขอบคุณมากๆครับ ผมขอรบกวนอีกสักนิดนะครับ ช่วยอธิบายความหมายของแต่ละส่วนให้ด้วยได้ไหมครับ เนื่องจากผมไม่ค่อยเก่ง VBA สักเท่าไหร่ แต่อยากจะประยุกต์สูตรเอาไว้ใช้งานกับไฟล์ข้อมูลที่มากขึ้นครับ ขอบคุณล่วงหน้าครับ

[snasui]

ต้องการทราบส่วนไหนกรุณาถามส่วนนั้น ขออภัยที่ไม่อธิบายรายบรรทัด การใช้ Code ควรศึกษามาก่อนตามลำดับครับ

[kit]

มีทั้งหมด 3 ส่วนครับ

ส่วนที่ 1
* Set d1 = CreateObject("Scripting.Dictionary") *

ส่วนที่ 2
* For Each r In rAll.Rows(1).Cells
d1.Add Key:=r.Value, Item:=r.Value
Next r
*

ส่วนที่ 3
* s = r.Parent.Cells(r.Row, 2).Value & "|" & _
r.Parent.Cells(2, r.Column).Value & "|" & _
r.Value
d3.Add Key:=s, Item:=s
*
ขอบคุณครับ

[snasui]

ส่วนที่ 1
Set d1 = CreateObject("Scripting.Dictionary")

เป็นการกำหนดค่าให้กับตัวแปร d1 ให้เป็น Object หนึ่งที่ชื่อว่า Scripting.Dictionary ซึ่ง Object ประเภทนี้สามารถเก็บค่าได้ 2 ค่าคือ key กับ item โดย key จะต้องไม่ซ้ำกัน ยกตัวอย่างเช่น คอลัมน์ A เก็บใน key คอลัมน์ B เก็บใน item โดย key ต้องไม่ซ้ำกันครับ

ส่วนที่ 2
For Each r In rAll.Rows(1).Cells
d1.Add Key:=r.Value, Item:=r.Value
Next r

เป็นการ Loop บรรทัดที่ 1 ของตัวแปร rAll ไปทีละตัว แล้วเก็บค่านั้นไปไว้ในตัวแปร d1 โดยให้ key และ item เป็นค่าเดียวกันคือค่าของตัวแปร r ครับ

ส่วนที่ 3
s = r.Parent.Cells(r.Row, 2).Value & "|" & _
r.Parent.Cells(2, r.Column).Value & "|" & _
r.Value
d3.Add Key:=s, Item:=s


เป็นการกำหนดค่าให้กับตัวแปร s โดยให้มีค่าเท่ากับ

1. ค่าในเซลล์ในบรรทัดเดียวกับตัวแปร r และอยู่ในคอลัมน์ที่ 2 เชื่อมกับ
2. ค่าในเซลล์ในบรรทัดที่ 2 และเป็นคอลัมน์เดียวกับตัวแปร r เชื่อมกับ
3. ค่าของตัวแปร r

สรุป เป็นการนำ 3 ค่ามาเชื่อมติดกันแล้วนำไปกำหนดให้กับตัวแปร s

จากนั้นนำตัวแปร s ไปกำหนดค่าให้กับตัวแปร d3 โดยให้ key และ item ของ d3 มีค่าเท่ากับตัวแปร s ครับ

[kit]

ขอบคุณมากครับ