VBA lấy tên columns và Row theo điều kiện "Màu"

[robinhsoon]

Thân chào cả nhà GPEX!

Hiện em có Một File gồm 02 Sheet (Data, KetQua)
Em muốn dùng VBA để xuất ra Kết Quả có tô màu vàng tương ứng với Số RespointID và tên cột.
ví dụ: Số Res 13454327 có 2 vùng tô vàng là -50% và 70%, thì tương ứng sẽ xuất ra kết quả tên cột ở vị trí tô vàng:

RespointID | Comment
- 13454327 | Q22_1XV1XH1
- 13454327 | Q24_1XV1XH1
P/S: em có đính kèm Data và Sheet KetQua em làm sẵn ạ.
Mong cả nhà giúp đỡ, em trân thành cảm ơn ạ.

 

[leonguyenz]

Thân chào cả nhà GPEX!

Hiện em có Một File gồm 02 Sheet (Data, KetQua)
Em muốn dùng VBA để xuất ra Kết Quả có tô màu vàng tương ứng với Số RespointID và tên cột.
ví dụ: Số Res 13454327 có 2 vùng tô vàng là -50% và 70%, thì tương ứng sẽ xuất ra kết quả tên cột ở vị trí tô vàng:

RespointID | Comment
- 13454327 | Q22_1XV1XH1
- 13454327 | Q24_1XV1XH1
P/S: em có đính kèm Data và Sheet KetQua em làm sẵn ạ.
Mong cả nhà giúp đỡ, em trân thành cảm ơn ạ.

Tham khảo code:

Sub Test()
Dim Rng As Range, Cel As Range, i&, j&, rArr()
With Sheets("Data")
    Set Rng = .Range("C2:Q4")
    ReDim rArr(1 To Rng.Rows.Count * Rng.Columns.Count, 1 To 2)
    For Each Cel In Rng
        If Cel.Interior.ColorIndex > 0 Then
            j = j + 1
            rArr(j, 1) = .Cells(Cel.Row, "A")
            rArr(j, 2) = .Cells(1, Cel.Column)
        End If
    Next Cel
End With
If j Then Sheets("KetQua").Range("A2").Resize(j, 2) = rArr
End Sub

 

[robinhsoon]

Tham khảo code:

Sub Test()
Dim Rng As Range, Cel As Range, i&, j&, rArr()
With Sheets("Data")
    Set Rng = .Range("C2:Q4")
    ReDim rArr(1 To Rng.Rows.Count * Rng.Columns.Count, 1 To 2)
    For Each Cel In Rng
        If Cel.Interior.ColorIndex > 0 Then
            j = j + 1
            rArr(j, 1) = .Cells(Cel.Row, "A")
            rArr(j, 2) = .Cells(1, Cel.Column)
        End If
    Next Cel
End With
If j Then Sheets("KetQua").Range("A2").Resize(j, 2) = rArr
End Sub

Em cảm ơn anh ạ, code hay và nhanh lắm ạ.

Em Chúc anh sức khỏe và thành công ạ.