Tìm đối tượng cấp cuối cùng trong mảng

[mhung12005]

Chào anh chị,

Tôi có bài toán này mà loay hoay mãi chưa giải được. Mong anh, chị, em giúp một đoạn code (hoặc ý tưởng cũng được) để giải giúp.
Chi tiết bài toán tôi đã giải thích trong file đính kèm.

Xin chân thành cảm ơn.

 

[batman1]

Nếu tôi hiểu được giải thích thì C13 phải rỗng chứ sao C13 = ".7" nhỉ.

 

[snow25]

Chào anh chị,

Tôi có bài toán này mà loay hoay mãi chưa giải được. Mong anh, chị, em giúp một đoạn code (hoặc ý tưởng cũng được) để giải giúp.
Chi tiết bài toán tôi đã giải thích trong file đính kèm.

Xin chân thành cảm ơn.

Thử.

Sub laychamcham()
    Dim arr, i As Long, j As Long, lr As Long, kq, a As Long, b As Integer, c As Integer
    With Sheets("bom")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         For i = 1 To UBound(arr) - 1
             b = demcham(arr(i, 1))
             c = demcham(arr(i + 1, 1))
             If b >= c Then
                kq(i, 1) = arr(i, 1)
             End If
         Next i
         kq(i, 1) = arr(i, 1)
         .Range("D2:D" & lr).Value = kq
  End With
    
End Sub
Function demcham(ByVal dk As String)
        Dim i As Long, a As Integer
        For i = 1 To Len(dk)
            If Mid(dk, i, 1) = "." Then
               a = a + 1
            End If
        Next i
        demcham = a
End Function

 

[mhung12005]

Nếu tôi hiểu được giải thích thì C13 phải rỗng chứ sao C13 = ".7" nhỉ.

Chính xác, tôi làm thủ công nên nhầm. C13 đúng phải rỗng

Bài đã được tự động gộp: 16/12/19

Thử.

Sub laychamcham()
    Dim arr, i As Long, j As Long, lr As Long, kq, a As Long, b As Integer, c As Integer
    With Sheets("bom")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         For i = 1 To UBound(arr) - 1
             b = demcham(arr(i, 1))
             c = demcham(arr(i + 1, 1))
             If b >= c Then
                kq(i, 1) = arr(i, 1)
             End If
         Next i
         kq(i, 1) = arr(i, 1)
         .Range("D2:D" & lr).Value = kq
  End With
   
End Sub
Function demcham(ByVal dk As String)
        Dim i As Long, a As Integer
        For i = 1 To Len(dk)
            If Mid(dk, i, 1) = "." Then
               a = a + 1
            End If
        Next i
        demcham = a
End Function

Tôi đã thử, và kết quả chính xác.
Cảm ơn bạn nhiều nhé

 

[batman1]

Công thức C2

=IF(LEN(A2)-LEN(SUBSTITUTE(A2,".",""))<LEN(A3)-LEN(SUBSTITUTE(A3,".","")),"",A2)

Code

Sub timchitiet()
Dim lastRow As Long, r As Long, data, a As Long, b As Long
    With ThisWorkbook.Worksheets("BOM")
        .Range("C2:C10000").ClearContents
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow < 2 Then Exit Sub
        data = .Range("A2:A" & lastRow + 1).Value
    End With
    For r = 1 To UBound(data) - 2
        a = InStrRev("." & data(r, 1), ".")
        b = InStrRev(data(r + 1, 1), ".")
        If a <= b Then data(r, 1) = Empty
    Next r
    With ThisWorkbook.Worksheets("BOM").Range("C2").Resize(UBound(data) - 1)
        .NumberFormat = "@"
        .Value = data
    End With
End Sub

 

[mhung12005]

Công thức C2

=IF(LEN(A2)-LEN(SUBSTITUTE(A2,".",""))<LEN(A3)-LEN(SUBSTITUTE(A3,".","")),"",A2)

Code

Sub timchitiet()
Dim lastRow As Long, r As Long, data, a As Long, b As Long
    With ThisWorkbook.Worksheets("BOM")
        .Range("C2:C10000").ClearContents
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow < 2 Then Exit Sub
        data = .Range("A2:A" & lastRow + 1).Value
    End With
    For r = 1 To UBound(data) - 2
        a = InStrRev("." & data(r, 1), ".")
        b = InStrRev(data(r + 1, 1), ".")
        If a <= b Then data(r, 1) = Empty
    Next r
    With ThisWorkbook.Worksheets("BOM").Range("C2").Resize(UBound(data) - 1)
        .NumberFormat = "@"
        .Value = data
    End With
End Sub

Cảm ơn bạn