Tìm dữ liệu tại cột B tương ứng với "So mon:" tại cột A trong vùng (vùng có độ rộng thay đổi)

[pham ha 94]

Em xin gửi lời cảm ơn trước tới các bác đã giúp đỡ rất nhiều trong thời gian qua.
Em có đính kèm file. Mong muốn sẽ tìm được giá trị tại cột A của Sheet VoSo tương ứng với row của So mon: ở cột B và trả dữ liệu về Sheet Data Voso
Em có sử dụng công thức excel nhưng nếu số lượng page bị trống So mon: càng nhiều thì hàm sẽ càng lặp lại nhiều rất dễ sai, khi lỗi không biết sửa ở đâu và chạy với số lượng lớn thì rất chậm.
Khi page chứa giá trị So mon: trong vùng thì trả về giá trị tại cột B
Khi page trống So mon: thì page đầu tiên sẽ trả về giá trị 33, các page sau sẽ trả về giá trị 38. Page cuối cùng gần nhất chứa So mon: sẽ trả về giá trị tại cột B trừ đi giá trị các ô đã gán giá trị trước đó.
Sau khi kết thúc page có So mon: thì sang page tiếp theo sẽ tính lại từ đầu.
Mong muốn có VBA để tăng được tốc độ xử lý và bao quát hơn vì dữ liệu lớn thì số cột sẽ phát sinh sai sót.
Một lần nữa, em xin cảm ơn các bác rất nhiều.

 

[SA_DQ]

Bạn thử với con rùa này của mình:

Sub TimChiSoDong()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
 Dim Arr(), MyAdd As String
 Dim Rws As Long, W As Integer
 
 Set Sh = ThisWorkbook.Worksheets("VoSo")
 Sheets("Data").Select
 Rws = Sh.Cells(9999, "A").End(xlUp).Row
 [A2].Resize(Rws, 3).ClearContents
 Set Rng = Sh.[B1].Resize(Rws)
 Set sRng = Rng.Find(" Page ", , xlFormulas, xlPart)
 If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        With Cells(Rws, "A").End(xlUp)
            .Offset(1).Value = sRng.Value
            .Offset(1, 1).Value = sRng.Row
        End With
        W = W + 1
        Set sRng = Rng.FindNext(sRng)
    Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
 End If
 Cells(Rws, "B").End(xlUp).Offset(1) = Rws
 For Each Cls In Range([B2], [B2].End(xlDown).Offset(-1))
    Set Rng = Sh.Range(Sh.Cells(Cls.Value, "A"), Sh.Cells(Cls.Offset(1).Value, "A"))
    For Each sRng In Rng
        If sRng.Value = "So mon:" Then
            Cls.Offset(, 1).Value = sRng.Offset(, 1).Value
            Cls.Offset(, 2).Value = sRng.Row
        End If
    Next sRng
 Next Cls
End Sub

Chú í: Tên trang tính!

 

[pham ha 94]

Bạn thử với con rùa này của mình:

Sub TimChiSoDong()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
 Dim Arr(), MyAdd As String
 Dim Rws As Long, W As Integer
 
 Set Sh = ThisWorkbook.Worksheets("VoSo")
 Sheets("Data").Select
 Rws = Sh.Cells(9999, "A").End(xlUp).Row
 [A2].Resize(Rws, 3).ClearContents
 Set Rng = Sh.[B1].Resize(Rws)
 Set sRng = Rng.Find(" Page ", , xlFormulas, xlPart)
 If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        With Cells(Rws, "A").End(xlUp)
            .Offset(1).Value = sRng.Value
            .Offset(1, 1).Value = sRng.Row
        End With
        W = W + 1
        Set sRng = Rng.FindNext(sRng)
    Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
 End If
 Cells(Rws, "B").End(xlUp).Offset(1) = Rws
 For Each Cls In Range([B2], [B2].End(xlDown).Offset(-1))
    Set Rng = Sh.Range(Sh.Cells(Cls.Value, "A"), Sh.Cells(Cls.Offset(1).Value, "A"))
    For Each sRng In Rng
        If sRng.Value = "So mon:" Then
            Cls.Offset(, 1).Value = sRng.Offset(, 1).Value
            Cls.Offset(, 2).Value = sRng.Row
        End If
    Next sRng
 Next Cls
End Sub

Chú í: Tên trang tính!

Cảm ơn bác nhiều. File đã tìm được số Sheet VoSo cột B và row của ô đó. Không biết bác có thể giúp em thêm phần trừ đi cho các ô bên trên được không ạ. Em có thử sửa vào code để trừ đi nhưng báo lỗi tùm lum luôn. (

 

[bebo021999]

Dùng thử code này xem sao

Sub Test()
Dim lr&, i&, j&, k&, t&, max&, sodong&, valu, rng
Dim res1(), res2(), somon()
Sheets("Data VoSo").Range("A2:B10000,E2:E10000").ClearContents
With Sheets("VoSo")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:B" & lr).Value
    sodong = WorksheetFunction.CountIf(.Range("B2:B" & lr), "*Page*")
    ReDim res1(1 To sodong, 1 To 2): ReDim res2(1 To sodong, 1 To 1)
    sodong = WorksheetFunction.CountIf(.Range("A2:A" & lr), "So mon:")
    ReDim somon(1 To sodong, 1 To 100)
    For i = 1 To UBound(rng)
        If rng(i, 2) Like "*Page*" Then
            j = j + 1: res1(j, 1) = rng(i, 2): res1(j, 2) = i + 1
        End If
    Next
    For i = 1 To UBound(rng)
        If rng(i, 1) = "So mon:" Then
            k = k + 1: somon(k, 1) = rng(i, 2): somon(k, 2) = i + 1
        End If
    Next
    Sheets("Data VoSo").Range("A2").Resize(UBound(res1), 2).Value = res1
    For i = 1 To UBound(somon)
        valu = somon(i, 1): k = 2
        For j = 1 To UBound(res1)
            If res1(j, 2) < somon(i, 2) Then
                k = k + 1
                somon(i, k) = IIf(valu < 33, valu, IIf(valu <= 38, valu, 38))
                If k = 3 And somon(i, 1) > 33 Then somon(i, 3) = 33
                valu = valu - somon(i, k)
                res1(j, 2) = lr + 1
                If k > max Then max = k
                t = t + 1: res2(t, 1) = somon(i, k)
            End If
        Next
    Next
End With
With Sheets("Data VoSo")
    .Range("E2").Resize(UBound(res2), 1).Value = res2
End With
End Sub

 

[pham ha 94]

Dùng thử code này xem sao

Sub Test()
Dim lr&, i&, j&, k&, t&, max&, sodong&, valu, rng
Dim res1(), res2(), somon()
Sheets("Data VoSo").Range("A2:B10000,E2:E10000").ClearContents
With Sheets("VoSo")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:B" & lr).Value
    sodong = WorksheetFunction.CountIf(.Range("B2:B" & lr), "*Page*")
    ReDim res1(1 To sodong, 1 To 2): ReDim res2(1 To sodong, 1 To 1)
    sodong = WorksheetFunction.CountIf(.Range("A2:A" & lr), "So mon:")
    ReDim somon(1 To sodong, 1 To 100)
    For i = 1 To UBound(rng)
        If rng(i, 2) Like "*Page*" Then
            j = j + 1: res1(j, 1) = rng(i, 2): res1(j, 2) = i + 1
        End If
    Next
    For i = 1 To UBound(rng)
        If rng(i, 1) = "So mon:" Then
            k = k + 1: somon(k, 1) = rng(i, 2): somon(k, 2) = i + 1
        End If
    Next
    Sheets("Data VoSo").Range("A2").Resize(UBound(res1), 2).Value = res1
    For i = 1 To UBound(somon)
        valu = somon(i, 1): k = 2
        For j = 1 To UBound(res1)
            If res1(j, 2) < somon(i, 2) Then
                k = k + 1
                somon(i, k) = IIf(valu < 33, valu, IIf(valu <= 38, valu, 38))
                If k = 3 And somon(i, 1) > 33 Then somon(i, 3) = 33
                valu = valu - somon(i, k)
                res1(j, 2) = lr + 1
                If k > max Then max = k
                t = t + 1: res2(t, 1) = somon(i, k)
            End If
        Next
    Next
End With
With Sheets("Data VoSo")
    .Range("E2").Resize(UBound(res2), 1).Value = res2
End With
End Sub

cảm ơn bác nhiều lắm
code quá tuyệt vời luôn