สอบถามการ Resize และ Merge Rows ตามจำนวนข้อมูลที่ซ้ำกัน

[niwat2811]

สอบถามการ Resize และ Merge Rows ตามจำนวนข้อมูลที่ซ้ำกันครับ
ตัวอย่างตามไฟล์แนบ คำตอบที่ต้องการอยู่ที่ คอลัมภน์ E:F
Code อยู่ที่ Module1 ชื่อ test1 ครับ

Code: Select all

Sub test1()
Dim rngMerge As Range
Dim cell As Range
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Set rngMerge = Range("A2:A" & lr)
Range("A2:A" & lr).MergeCells = False
MergeAgain:
Application.DisplayAlerts = False
For Each cell In rngMerge
    If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            Range(cell, cell.Offset(1, 0)).VerticalAlignment = xlTop
        GoTo MergeAgain
    End If
Next
Application.DisplayAlerts = True
End Sub

[ZEROV]

ตัวอย่างการหาช่วงเซลล์เพื่อทำการ Merge

Code: Select all

Sub FindMergeRange()
Dim ArrRange, CalRange
lastrow = Range("a" & Rows.Count).End(xlUp).Row
Set CalRange = Range("c2:c" & lastrow)
[c2] = "=IF(MATCH(A2,A:A,0)=ROW(),COUNTIF(A:A,A2))"
[c2].Copy (CalRange)
CalRange.Value = CalRange.Value
  Set ArrRange = CalRange.SpecialCells(xlCellTypeConstants, 1)
    For Each cll In ArrRange
       cll.Offset(0, -2).Resize(cll.Value, 1).Select
       Call Merge
    Next
    MsgBox "Done"
End Sub


Private Sub Merge()
MsgBox "Call Merge"
'............
End Sub

[niwat2811]

จาก Code ด้านบนที่ผมได้แจ้งไว้ สามารถใช้งานได้แค่คอลัมภน์ A
แต่ความต้องการคือ อยากให้ Merge Rows ที่คอลัมภน์ B ด้วย
ไม่ทราบว่าควรปรับ Code อย่างไรครับ

[DhitiBank]

ลองอีกแบบหนึ่งครับ

Code: Select all

Sub TryMerge()
    Dim i As Integer, iCount As Integer, iCol As Integer, _
        r As Range, rMerge As Range, bOK As Boolean
    With ActiveSheet
        iCol = .UsedRange.Columns.Count
        Set rMerge = .UsedRange.Resize(.UsedRange.Rows.Count, 1)
    End With
    Application.DisplayAlerts = False
    For i = iCol To 1 Step -1
        For Each r In rMerge.Offset(, i - 1)
            If r.MergeCells Then Exit For
            If Not IsEmpty(r) Then
                If i > 1 Then
                    bOK = False
                    If r.Offset(0, -1).Value = _
                        r.Offset(1, -1).Value Then bOK = True
                Else
                    bOK = True
                End If
                If r.Value = r.Offset(1, 0).Value And bOK Then
                    iCount = iCount + 1
                Else
                    If iCount > 0 Then
                        r.Offset(-iCount, 0).Resize(iCount + 1, 1).Merge
                        r.Offset(-iCount, 0).VerticalAlignment = xlTop
                        iCount = 0
                    End If
                End If
            End If
        Next r
    Next i
    Application.DisplayAlerts = True
End Sub

[niwat2811]

ขอบคุณ คุณ DhitiBank มากครับ
Code ที่ให้มาสามารถนำไปใช้งานได้ตรงตามต้องการครับ

[ZEROV]

สร้างใหม่ใน Column ถัดไป

Code: Select all

Public Sub MergeCell()
Dim DataCol1 As Range, Main As Range, m, n
Set DataCol1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
For Each c In DataCol1
        If c.Value <> m Then
            Set Main = c.Resize(iCount(DataCol1, c.Value), 1)
            c.Offset(0, 2).Value = c.Value
            c.Offset(0, 2).Resize(iCount(DataCol1, c.Value), 1).Merge
            c.Offset(0, 3).Value = c.Offset(0, 1).Value
            c.Offset(0, 3).Resize(iCount(Main.Offset(0, 1), c.Offset(0, 1).Value)).Merge
            m = c.Value
            n = c.Offset(0, 1).Value
        End If
        If c.Offset(0, 1).Value <> n Then
                c.Offset(0, 3).Value = c.Offset(0, 1).Value
                c.Offset(0, 3).Resize(iCount(Main.Offset(0, 1), c.Offset(0, 1).Value)).Merge
                n = c.Offset(0, 1).Value
        End If
Next
Columns("C:D").VerticalAlignment = xlTop
End Sub
Private Function iCount(R As Range, x As String) As Integer
For Each i In R
If i = x Then n = n + 1
Next i
iCount = n
End Function