Lấy dữ liệu trong bảng tính, xắp xếp dựa theo comment của từng Cells (1 người xem)

[Cao Mạnh Sơn]

Tôi có 1 bảng tính trong đó các cells có nội dung comment bên trong. Nhờ mọi người giúp viết code để lấy dữ liệu theo nội dung comment và xắp xếp theo ý muốn.
Chi tiết trong bảng tính đính kèm. Hy vọng nhận được giúp đỡ nhiệt tình của mọi người.
Cám ơn

 

[Cao Mạnh Sơn]

Bài này đưa lên mà không ai có ý kiến trả lời. Tủi thân quá

 

[SA_DQ]

Hôm nay mới thấy bài này!

Option Explicit
Sub ForCommentValues()
 Dim Dat As Date, SoNg As Long, jJ As Long
 Dim Rng As Range, sRng As Range, Rg0 As Range, cRng As Range, Cls As Range
 Dim WF As Object, MyAdd As String
    
 Set Rng = Range([a2], [a2].End(xlDown))
 Rng.NumberFormat = "mm/dd/yyyy"
 [G2:j2].CurrentRegion.Offset(1).ClearContents
 Set WF = Application.WorksheetFunction
 Dat = WF.Min(Rng):                 SoNg = WF.Max(Rng) - Dat
 For jJ = 0 To SoNg
    Set sRng = Rng.Find(Format(Dat + jJ, "mm/dd/yyyy"), , xlValues, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            If cRng Is Nothing Then
                On Error Resume Next
                Set cRng = Range(sRng.Offset(, 1), _
                    sRng.End(xlToRight)).SpecialCells(xlCellTypeComments)
                On Error GoTo 0
            Else
                Set cRng = Union(cRng, Range(sRng.Offset(, 1), _
                    sRng.End(xlToRight)).SpecialCells(xlCellTypeComments))
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
    If Not cRng Is Nothing Then
        For Each Cls In cRng
            With [G65500].End(xlUp).Offset(1)
                .Value = Dat + jJ
                .Offset(, 1).Value = Mid(Cls.Comment.Text, 3 + Len(Cls.Comment.Author), 9)
                .Offset(, 2).Value = Cells(2, Cls.Column).Value
                .Offset(, 3).Value = Cells(sRng.Row, Cls.Column).Value
            End With
        Next Cls
        Set cRng = Nothing
    Else
'        MsgBox "Nothing", , Dat + jJ '
    End If
 Next jJ
End Sub

 

[Cao Mạnh Sơn]

Cám ơn bác SA, dạo này em bận quá nên hôm nay mới vào ktra thấy bài của bác. cám ơn bác nhé. Để em ktra kết quả

 

[ChanhTQ@]

Sau đây là macro sau khi mình đưa câu hỏi của bạn lên mạng

Cám ơn bác, dạo này em bận quá nên hôm nay mới vào ktra thấy bài của bác. cám ơn bác nhé. Để em ktra kết quả

Option Explicit
Sub ertert()
'Copyright Nilem, Ufa, Russia; #5/21/2012#, 01:27AM '
Dim Rng As Range, Mg(), I&
With Range("A2").CurrentRegion
    ReDim Mg(1 To .SpecialCells(xlCellTypeComments).Count, 1 To 4)
    For Each Rng In .SpecialCells(xlCellTypeComments)
        I = I + 1
        Mg(I, 1) = .Item(Rng.Row, 1)
        MsgBox Cells(Rng.Row, 1).Value
        Mg(I, 2) = Split(Rng.Comment.Text, Chr(10))(1)
        Mg(I, 3) = .Item(2, Rng.Column)
        Mg(I, 4) = Rng.Value
    Next
End With
With Range("G1:J1")
    .Value = Array("Date", "Comment", "Type", "Quantity")
    With .Offset(1).Resize(I)
        .Value = Mg()
        .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
    End With
End With
End Sub

 

[Cao Mạnh Sơn]

Cám ơn bác ChanhTQ@, em sẽ ktra sau.
Gửi bác SA_DQ:
sau một hồi làm được và không làm được, em gửi file lên nhờ bác ktra hộ em
1: tại Sheet CHINH1: OK
2: Tại Sheet CHINH: báo lỗi ở dòng
Else
'Set cRng = Union(cRng, Range(sRng.Offset(, 7), sRng.End(xlToRight)).SpecialCells(xlCellTypeComments))
Set cRng = Union(cRng, Range(sRng.Offset(, 7), sRng.Offset(, 22)).SpecialCells(xlCellTypeComments))
End If
3: Em muốn thay thế giá trị tuyệt đối của Range("B... thành giá trị tương đối Range("B" & t+4... nhưng kết quả chạy không ra

 

[Cao Mạnh Sơn]

Code do bác Chanh_TQ@ sưu tầm em thấy chạy khá tốt, kể cả trường hợp cột B và C có các cells merge.

 

[SA_DQ]

Code do bác Chanh_TQ@ sưu tầm em thấy chạy khá tốt, kể cả trường hợp cột B và C có các cells merge.

Là tại chú thôi, Với VBA thì "merge Cells" là kẻ thù mà!