Lọc tên và giá trị của mẫu xét nghiệm

[FATA11]

Xin chào mọi người,
Từ kết quả xét nghiệm cột B đến D

Mình muốn lọc lấy tên (w1, w3,..) và giá trị trung bình (Average) tương ứng
với điều kiện: nếu tên thí nghiệm liên tục thì viết liền nhau, không liên tục thì viết cách ô.

Kết quả mong muốn mình có nhập tay ở cột G và cột H

Mong mọi người giúp đỡ.

 

[bebo021999]

Dùng đỡ củ chuối này trong khi chờ phương án khác hay hơn:

Option Explicit
Sub thinghiem()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 2)
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("B2:D" & lr).Value
For i = 1 To UBound(rng) - 2
    If LCase(rng(i, 1)) Like "w*" Then
        k = k + 1: arr(k, 1) = rng(i, 1)
        For j = i + 1 To i + 6
            If j <= UBound(rng) Then
                If LCase(rng(j, 1)) Like "average*" Then
                    arr(k, 2) = rng(j, 3)
                    If j < UBound(rng) Then k = k + IIf(IsEmpty(rng(j + 1, 1)), 1, 0)
                    Exit For
                End If
            End If
        Next
    End If
Next
' dan ket qua vào cot G:H. Thay doi qua vung khac neu muon.
Range("G2:H10000").ClearContents
Range("G2").Resize(k, 2).Value = arr
End Sub

 

[FATA11]

Dùng đỡ củ chuối này trong khi chờ phương án khác hay hơn:

Option Explicit
Sub thinghiem()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 2)
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("B2:D" & lr).Value
For i = 1 To UBound(rng) - 2
    If LCase(rng(i, 1)) Like "w*" Then
        k = k + 1: arr(k, 1) = rng(i, 1)
        For j = i + 1 To i + 6
            If j <= UBound(rng) Then
                If LCase(rng(j, 1)) Like "average*" Then
                    arr(k, 2) = rng(j, 3)
                    If j < UBound(rng) Then k = k + IIf(IsEmpty(rng(j + 1, 1)), 1, 0)
                    Exit For
                End If
            End If
        Next
    End If
Next
' dan ket qua vào cot G:H. Thay doi qua vung khac neu muon.
Range("G2:H10000").ClearContents
Range("G2").Resize(k, 2).Value = arr
End Sub

Em xin cảm ơn Anh