Merge เซลที่มีค่าเหมือนกัน แต่สูตรทำการMergeค่าBlankติดมาด้วย

[Botman03]

สวัสดีครับพี่ๆ ผมได้ทำสูตรเพื่อที่จะMerge ค่าซ้ำของเซลเข้าด้วยกัน ดังตัวอย่างรูปA >>> รูปBแต่ ปัญหาคือ เมื่อทำการRun สูตร ดังในรูปที่2 พื้นที่สีเหลือง (สูตรได้ทำการMerge ค่า Blank มาด้วย ทำให้เป็นส่วนเกินครับ)
พอจะมีแนวทางการแก้มั้ยครับ พยายามนั่งคิดแล้วคิดไม่ออกครับ สูตรที่ผมใช้คือ

Code: Select all

Sub MergeSameCell()
'Updateby20171127
Sheet9.Select
ActiveSheet.Unprotect
Dim Rng As Range, xCell As Range
Dim xRows As Integer
xTitleId = "KutoolsforExcel"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WorkRng = Range("A5:B500,E5:G500")
xRows = Range("A" & Rows.Count).End(xlUp).Row
For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).HorizontalAlignment = xlCenter
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).VerticalAlignment = xlCenter
        i = j - 1
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.Protect
End Sub

A.JPG

B.JPG

[snasui]

แนบไฟล์ Excel มาด้วยจะได้สะดวกในการปรับปรุงและทดสอบ Code ครับ

[Botman03]

แนบไฟล์ Excel มาด้วยจะได้สะดวกในการปรับปรุงและทดสอบ Code ครับ

ขอโทษทีครับ พอดีไฟล์เป็นไฟล์ในบริษัท โดนล็อคไว้ครับ ก็เลยไม่สามารถแนบได้

[snasui]

ทำตัวอย่างไฟล์เลียนแบบขึ้นมาครับ

การสอบถามปัญหาเราไม่ควรแนบไฟล์จริง ถ้าเป็นไฟล์จริงก็ควรแปลงข้อมูลสำคัญไปเป็นอย่างอื่น อ่านกฎการใช้บอร์ดทุกข้อด้านบนซ้ำอีกครั้งครับ

[Botman03]

ทำตัวอย่างไฟล์เลียนแบบขึ้นมาครับ

การสอบถามปัญหาเราไม่ควรแนบไฟล์จริง ถ้าเป็นไฟล์จริงก็ควรแปลงข้อมูลสำคัญไปเป็นอย่างอื่น อ่านกฎการใช้บอร์ดทุกข้อด้านบนซ้ำอีกครั้งครับ

ไฟล์แนบนะครับ ขอบคุณมากครับ

[snasui]

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

xRows = Range("A5", Range("A" & Rows.Count).End(xlUp)).Rows.Count