Giúp tách ô merge thành các giá trị bằng nhau giữa các ô (1 người xem)

[Nhattanktnn]

Chào anh chị và các bạn,
Mình có 1 cột ô trộn ô không. Nhờ mọi người giúp khi bỏ trộn ô đó thì giá trị trong ô trộn sẽ chia đều ra các ô,
Ví dụ có 4 cell trong cùng 1 cột trộn với nhau, giá trị hiển thị khi trộn là 1, vậy sau khi bỏ trộn là 4 ô mỗi ô bằng 0.25 (tức 1 chia 4 ô)
Xin lưu ý thêm: file này nhận từ bộ phận khác làm nên đôi khi có nhưng ô họ đã bỏ merge ( và bên dưới không có giá trị) thì các ô trống phía dưới và giá trị bên trên cũng chia đều cho bấy nhiêu ô nhé
Cảm ơn anh chị và các bạn!

 

[PacificPR]

Chào anh chị và các bạn,
Mình có 1 cột ô trộn ô không. Nhờ mọi người giúp khi bỏ trộn ô đó thì giá trị trong ô trộn sẽ chia đều ra các ô,
Ví dụ có 4 cell trong cùng 1 cột trộn với nhau, giá trị hiển thị khi trộn là 1, vậy sau khi bỏ trộn là 4 ô mỗi ô bằng 0.25 (tức 1 chia 4 ô)
Xin lưu ý thêm: file này nhận từ bộ phận khác làm nên đôi khi có nhưng ô họ đã bỏ merge ( và bên dưới không có giá trị) thì các ô trống phía dưới và giá trị bên trên cũng chia đều cho bấy nhiêu ô nhé
Cảm ơn anh chị và các bạn!

Bạn tham khảo thử

 

[Nhattanktnn]

Bạn tham khảo thử

Đúng là quan trọng ở thuật toán, mình xem công thức thì hiểu mà tự nghĩ ra thì không nghĩ được
Cảm ơn bạn nhé!
Nếu được bạn có thể giúp mình thêm code được không? không phải vì mình lười đâu mà vì cũng muốn học hỏi thêm!
(Mà hình như đây là chị gái xinh đẹp thì phải hì hì )

 

[HieuCD]

Chào anh chị và các bạn,
Mình có 1 cột ô trộn ô không. Nhờ mọi người giúp khi bỏ trộn ô đó thì giá trị trong ô trộn sẽ chia đều ra các ô,
Ví dụ có 4 cell trong cùng 1 cột trộn với nhau, giá trị hiển thị khi trộn là 1, vậy sau khi bỏ trộn là 4 ô mỗi ô bằng 0.25 (tức 1 chia 4 ô)
Xin lưu ý thêm: file này nhận từ bộ phận khác làm nên đôi khi có nhưng ô họ đã bỏ merge ( và bên dưới không có giá trị) thì các ô trống phía dưới và giá trị bên trên cũng chia đều cho bấy nhiêu ô nhé
Cảm ơn anh chị và các bạn!

Sub ABC()
  Dim Rng As Range, Res()
  Dim i&, fR&, eRow&, eRow2&, sRow&, tmp#
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eRow = eRow + .Range("A" & eRow).MergeArea.Rows.Count - 1
    Set Rng = .Range("A2:A" & eRow)
  End With
  sRow = Rng.Rows.Count
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    If Rng(i, 1) <> Empty Then fR = i
    Res(fR, 1) = Res(fR, 1) + 1
  Next i
  For i = 1 To sRow
    If Rng(i, 1) <> Empty Then tmp = Rng(i, 1) / Res(i, 1)
    Res(i, 1) = tmp
  Next i
'***** Cach 1
  Sheets("Sheet1").Range("B2").Resize(sRow) = Res
'*****
'***** Cach 2
  'Rng.Clear
  'Rng.Value = Res
'*****
End Sub

 

[Nhattanktnn]

Sub ABC()
  Dim Rng As Range, Res()
  Dim i&, fR&, eRow&, eRow2&, sRow&, tmp#
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eRow = eRow + .Range("A" & eRow).MergeArea.Rows.Count - 1
    Set Rng = .Range("A2:A" & eRow)
  End With
  sRow = Rng.Rows.Count
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    If Rng(i, 1) <> Empty Then fR = i
    Res(fR, 1) = Res(fR, 1) + 1
  Next i
  For i = 1 To sRow
    If Rng(i, 1) <> Empty Then tmp = Rng(i, 1) / Res(i, 1)
    Res(i, 1) = tmp
  Next i
'***** Cach 1
  Sheets("Sheet1").Range("B2").Resize(sRow) = Res
'*****
'***** Cach 2
  'Rng.Clear
  'Rng.Value = Res
'*****
End Sub

Cảm ơn bác Hiếu rất nhiều! rất đúng ý em, để em "gặm nhấm" xem khi nào vào tới ruột hì hì

 

[Phuocam]

. . .