Không nghịch đâu, vì
Vậy có code nào mà chỉ ra từ A1:A7 có 3 phần merge.
ThuNghi xem thử chổ này nhé: http://www.ozgrid.com/forum/showthread.php?t=22501&page=1
Vậy nhờ NDU tiện down giúp file trên và up lên giúp. Vì chưa đăng ký nên lại phải đăng ký.
"Nguyên con" đây, chưa sửa gì nhé! ThuNghi mang về có thể rút gọn được đấy
Mình làm lại cái code trên để lấy giá trị cột A thôi. NDU xem và chỉnh lại giúp nhé, thấy lộn xộn quá. Cám ơn.
Option Explicit
Sub FindMergedCells()
Dim LastRow As Long, r As Long, s As Long
Dim MyAddr As String, MyTmp As String
Dim bien
With Sheets("TestPage")
LastRow = .UsedRange.Rows(ActiveSheet.UsedRange.Rows.count).Row
'LastRow = .Cells(65000, 1).End(xlUp).Row'
End With
Sheets("TestPage").Select
s = 1
For r = 1 To LastRow
Cells(r, 1).Select
MyAddr = Selection.Address
If InStr(MyAddr, ":") > 0 Then
If MyTmp <> MyAddr Then bien = Cells(r, 1)
Cells(s, 5) = MyAddr
Cells(s, 6) = bien
MyTmp = MyAddr
Else
Cells(s, 5) = MyAddr
Cells(s, 6) = Cells(r, 1)
MyTmp = ""
End If
s = s + 1
Next r
End SubTôi thì làm vầy:
Private Function FindMCell(SrcRng As Range)
Dim Clls As Range, Tmp As String
With CreateObject("Scripting.Dictionary")
For Each Clls In SrcRng
If Clls.MergeCells Then
Tmp = Clls.MergeArea.Address
If Not .Exists(Tmp) Then .Add Tmp, ""
End If
Next
FindMCell = .Keys
End With
End FunctionSub Main()
Dim Arr
Arr = FindMCell(ActiveSheet.UsedRange)
Range("E1").Resize(UBound(Arr) + 1) = WorksheetFunction.Transpose(Arr)
End SubCám ơn NDU nhiều.
Thì sửa lại tí thôi mà:
Private Function FindMCell(SrcRng As Range)
Dim Clls As Range, Tmp As String, n As Long, Arr()
With CreateObject("Scripting.Dictionary")
For Each Clls In SrcRng
If Clls.MergeCells Then
Tmp = Clls.MergeArea.Address
If Not .Exists(Tmp) Then
n = n + 1
.Add Tmp, ""
ReDim Preserve Arr(1 To 2, 1 To n)
Arr(1, n) = Tmp
Arr(2, n) = Clls.Value
End If
End If
Next
FindMCell = WorksheetFunction.Transpose(Arr)
End With
End FunctionSub Main()
Dim Arr
With Sheet1
Arr = FindMCell(.Range([A1], [A65536].End(xlUp)))
.Range("E1:F1").Resize(UBound(Arr)) = Arr
End With
End SubHay nhất bài này là
Nhờ có NDU mình làm OK rồi, cám ơn rất nhiều. Làm đơn giản thôi, dùng Dic có vẻ đao to quá vì mình chỉ cần tới đó.
Sub GetMergedCells01()
Dim LastRow As Long, r As Long, MyTmp As String, MyAdd As String
Dim ArrKQ()
With Sheets("TestPage")
LastRow = .UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
.Columns("E:F").ClearContents
End With
ReDim ArrKQ(1 To LastRow, 1 To 2)
MyAdd = ""
With Sheets("TestPage")
For r = 1 To LastRow
If .Cells(r, 1).MergeCells Then
MyTmp = .Cells(r, 1).MergeArea.Address
If InStr(MyAdd, MyTmp) = False Then
MyAdd = MyAdd & MyTmp
ArrKQ(r, 2) = .Cells(r, 1)
Else
ArrKQ(r, 2) = ArrKQ(r - 1, 2)
End If
Else
ArrKQ(r, 2) = .Cells(r, 1)
End If
ArrKQ(r, 1) = .Cells(r, 1).Address
Next r
.[E1].Resize(r - 1, 2) = ArrKQ
End With
Erase ArrKQ()
End Sub
