Hỗ trợ hàm UDF sao y bản chính FLATTEN

Tình nghĩa giang hồ · 1/6/22

Chào anh chị, google có hàm Flatten cũng khá hay.

Mình có cách nào sao y hàm này về Excel bằng hàm UDF không anh chị, nếu cải tiến thêm 1 tí thì quá tuyệt.
Hàm cải tiến thì giống: = SORT(FLATTEN(Vùng dữ liệu))
Nhờ anh chị hỗ trợ giúp em trường hợp này.

Em cảm ơn anh chị.

snow25 · 1/6/22

Tình nghĩa giang hồ đã viết:
Chào anh chị, google có hàm Flatten cũng khá hay.

Mình có cách nào sao y hàm này về Excel bằng hàm UDF không anh chị, nếu cải tiến thêm 1 tí thì quá tuyệt.
Hàm cải tiến thì giống: = SORT(FLATTEN(Vùng dữ liệu))
Nhờ anh chị hỗ trợ giúp em trường hợp này.

Em cảm ơn anh chị.

Nhìn cái hình chẳng biết thế nào bạn phải nói rõ ra chứ.

Maika8008 · 1/6/22

Tình nghĩa giang hồ đã viết:
Chào anh chị, google có hàm Flatten cũng khá hay.

Mình có cách nào sao y hàm này về Excel bằng hàm UDF không anh chị, nếu cải tiến thêm 1 tí thì quá tuyệt.
Hàm cải tiến thì giống: = SORT(FLATTEN(Vùng dữ liệu))
Nhờ anh chị hỗ trợ giúp em trường hợp này.

Em cảm ơn anh chị.

Tôi nghĩ viết không khó nhưng chẳng biết để làm gì và cũng lười nên ... thôi.

VetMini · 1/6/22

Tình nghĩa giang hồ đã viết:
Chào anh chị, google có hàm Flatten cũng khá hay.
...

Tại họ dùng từ ngữ như vậy.
Flatten của họ có nghĩa là Unpivot của nơi khác.
Chịu khó tìm hiểu Unpivot của MS thì ra.

johnnylinhanh · 1/6/22

Mình tạm thời tạo 1 hàm Flatten_UDF() có chức năng giống như hàm FLATTEN() trên google spreadsheet
Ở sheet1 ô M5 mình có sử dụng hàm mẫu, Chú ý hàm cho phép chọn tối đa 7 dải ô nhé

Rich (BB code):

Function Flatten_UDF(ByVal rng1 As Range, Optional ByVal rng2 As Range, Optional ByVal rng3 As Range, Optional ByVal rng4 As Range, Optional ByVal rng5 As Range, Optional ByVal rng6 As Range, Optional ByVal rng7 As Range)
Dim r&, k&, r1&, r2&, r3&, r4&, r5&, r6&, r7&, c1&, c2&, c3&, c4&, c5&, c6&, c7
On Error Resume Next
r1 = rng1.Rows.Count: c1 = rng1.Columns.Count
r2 = rng2.Rows.Count: c2 = rng2.Columns.Count
r3 = rng3.Rows.Count: c3 = rng3.Columns.Count
r4 = rng4.Rows.Count: c4 = rng4.Columns.Count
r5 = rng5.Rows.Count: c5 = rng5.Columns.Count
r6 = rng6.Rows.Count: c6 = rng6.Columns.Count
r7 = rng7.Rows.Count: c7 = rng7.Columns.Count

r = r1 * c1 + r2 * c2 + r3 * c3 + r4 * c4 + r5 * c5 + r6 * c6 + r7 * c7
ReDim arr(1 To r, 1 To 1)
k = 0
For j = 1 To c1
    For i = 1 To r1
        k = k + 1
        If rng1(i, j) <> Empty Then arr(k, 1) = rng1(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c2
    For i = 1 To r2
        k = k + 1
        If rng2(i, j) <> Empty Then arr(k, 1) = rng2(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c3
    For i = 1 To r3
        k = k + 1
        If rng3(i, j) <> Empty Then arr(k, 1) = rng3(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c4
    For i = 1 To r4
        k = k + 1
        If rng4(i, j) <> Empty Then arr(k, 1) = rng4(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c5
    For i = 1 To r5
        k = k + 1
        If rng5(i, j) <> Empty Then arr(k, 1) = rng5(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c6
    For i = 1 To r6
        k = k + 1
        If rng6(i, j) <> Empty Then arr(k, 1) = rng6(i, j) Else arr(k, 1) = ""
    Next i
Next j
For j = 1 To c7
    For i = 1 To r7
        k = k + 1
        If rng7(i, j) <> Empty Then arr(k, 1) = rng7(i, j) Else arr(k, 1) = ""
    Next i
Next j
Flatten_UDF = arr
End Function

Qua đây nhờ các bác, anh, chị gợi ý giúp em 2 vấn đề:
1. Có cách nào tại các hàm UDF mình truyền nhiều tham số Optional mà không phải giới hạn là 7 như code của em ở trên không?
2. Nếu phần tử trên mảng arr() bằng Empty thì khi gán kết quả vào nó lại hiển thị dưới Cell bằng 0 => nên em đặt tạm: If rng7(i, j) <> Empty Then arr(k, 1) = rng7(i, j) Else arr(k, 1) = "". Ngoài cách này ra còn có cách xử lý nào khác không ạ?

Maika8008 · 1/6/22

Bạn tham khảo cách dùng ParamArray khi viết hàm UDF.

VetMini · 1/6/22

Dùng MS Excel Power Query. Ở trên tôi đã gợi ý cho từ khóa Unpivot rồi.
Từ Flatten là từ kỹ thutaaj. Unpivot là từ chính thức của Database. Thằng Google nhắm vào quần chúng không chuyên nghiệp nên cố ý dùng từ không chuyên nghiệp.

johnnylinhanh đã viết:
...
1. Có cách nào tại các hàm UDF mình truyền nhiều tham số Optional mà không phải giới hạn là 7 như code của em ở trên không?
...

1. nghiên cứu dùng paramarray. Ở đây (GPE) có cả đống.

johnnylinhanh · 1/6/22

Maika8008 đã viết:
Bạn tham khảo cách dùng ParamArray khi viết hàm UDF.

VetMini đã viết:
Dùng MS Excel Power Query. Ở trên tôi đã gợi ý cho từ khóa Unpivot rồi.
Từ Flatten là từ kỹ thutaaj. Unpivot là từ chính thức của Database. Thằng Google nhắm vào quần chúng không chuyên nghiệp nên cố ý dùng từ không chuyên nghiệp.

1. nghiên cứu dùng paramarray. Ở đây (GPE) có cả đống.

Cám ơn hai bác đã gợi ý từ khóa ạ :throb:

Còn vấn đề số 2 là giá trị Empty trong mảng khi gán xuống cell nó tự hiển thị là 0 thì ngoại trừ gán "" vào mảng nếu Empty thì còn cách nào khác tốt hơn không ạ

Phần yêu cầu cải tiến thêm Sort thì thớt tham khảo bài #33 này có 1 hàm tự tạo khác => lồng 2 hàm này với nhau là ra yêu cầu của thớt rồi á

VetMini · 1/6/22

Bạn viết code không ngắt dòng, dài quá nên đọc dễ bị sót.
Tôi khong thấy cái mảng nó được khai báo chỗ nào cho nên không thể đoán.

befaint · 1/6/22

Tình nghĩa giang hồ đã viết:
hàm Flatten cũng khá hay

Không phải là khá hay, mà quá hay.

Hàm Flatten nhận đối số là giá trị đơn, Range, Array được hết.

=FLATTEN(B10,"giá trị 1",A1:A1000,D4:Z5,"giá trị 2")

= FLATTEN(A3:A20 & "sDelim" & B2:E2 & "sDelim" & B3:E20)

johnnylinhanh · 1/6/22

VetMini đã viết:
Bạn viết code không ngắt dòng, dài quá nên đọc dễ bị sót.
Tôi khong thấy cái mảng nó được khai báo chỗ nào cho nên không thể đoán.

Em chỉnh lại code cho dễ nhìn ở giao diện Mobile ạ
Phần mảng em khai báo tại Dòng tô đỏ nhé anh

Rich (BB code):

Function Flatten_UDF(ByVal rng1 As Range, _
    Optional ByVal rng2 As Range, _
    Optional ByVal rng3 As Range, _
    Optional ByVal rng4 As Range, _
    Optional ByVal rng5 As Range, _
    Optional ByVal rng6 As Range, _
    Optional ByVal rng7 As Range)

Dim r&, k&, r1&, r2&, r3&, r4&, r5&, _
    r6&, r7&, c1&, c2&, c3&, c4&, c5&, c6&, c7

On Error Resume Next

r1 = rng1.Rows.Count: c1 = rng1.Columns.Count
r2 = rng2.Rows.Count: c2 = rng2.Columns.Count
r3 = rng3.Rows.Count: c3 = rng3.Columns.Count
r4 = rng4.Rows.Count: c4 = rng4.Columns.Count
r5 = rng5.Rows.Count: c5 = rng5.Columns.Count
r6 = rng6.Rows.Count: c6 = rng6.Columns.Count
r7 = rng7.Rows.Count: c7 = rng7.Columns.Count

r = r1 * c1 + r2 * c2 + r3 * c3 + r4 * c4 + _
    r5 * c5 + r6 * c6 + r7 * c7

ReDim arr(1 To r, 1 To 1)
k = 0
For j = 1 To c1
    For i = 1 To r1
        k = k + 1
        If rng1(i, j) <> Empty Then
            arr(k, 1) = rng1(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c2
    For i = 1 To r2
        k = k + 1
        If rng2(i, j) <> Empty Then
            arr(k, 1) = rng2(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c3
    For i = 1 To r3
        k = k + 1
        If rng3(i, j) <> Empty Then
            arr(k, 1) = rng3(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c4
    For i = 1 To r4
        k = k + 1
        If rng4(i, j) <> Empty Then
            arr(k, 1) = rng4(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c5
    For i = 1 To r5
        k = k + 1
        If rng5(i, j) <> Empty Then
            arr(k, 1) = rng5(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c6
    For i = 1 To r6
        k = k + 1
        If rng6(i, j) <> Empty Then
            arr(k, 1) = rng6(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
For j = 1 To c7
    For i = 1 To r7
        k = k + 1
       If rng7(i, j) <> Empty Then
            arr(k, 1) = rng7(i, j)
        Else
            arr(k, 1) = ""
        End if
    Next i
Next j
Flatten_UDF = arr
End Function

VetMini · 1/6/22

Tôi không dùng Mobile.
Vẫn chưa nhìn ra được Arr khai báo chỗ nào.
Dim Arr() As Variant
ReDim Arr(....)

Trong bảng tính, nơi chép dữ liệu vào phải mặc định là General.

Chú thích:
Ba cái mớ r1-r7, c1-c7 rườm rà quá. Cỡ 5 trở lên thì người ta dùng mảng cho gọn.

johnnylinhanh · 1/6/22

Ba cái mớ r1-r7, c1-c7 rườm rà quá. Cỡ 5 trở lên thì người ta dùng mảng cho gọn.

Vâng em xin rút kinh nghiệm và tranh thủ tìm hiểu thêm ParramArray

Còn việc hiển thị giá trị 0 thì em thấy vấn đề nằm ở chỗ dòng tô vàng test = arr() như hình bên dưới á anh
Rõ ràng trong cửa sổ Locals nó là Empty nhưng khi gán vào test để xuất kết quả thì lại ra 0
=> có cách nào nó gán xuống cell là Empty mà không phải gán phần tử arr() = Empty thành "" không anh

Hoàng Tuấn 868 · 1/6/22

johnnylinhanh đã viết:
tranh thủ tìm hiểu thêm ParramArray

Chỉ có ParamArray thôi, không có ParramArray đâu bạn à.

HeSanbi · 2/6/22

Flatten Google Sheet + Sort

=S_FLATTEN(0,A1:B4,"Hello",1,E5:G9)
=S_FLATTEN(1,A1:B4,"Hello",1,E5:G9)
=S_FLATTEN(-1,A1:B4,"Hello",1,E5:G9)

JavaScript:

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Caller As Range
  results As Variant
  rows As Long
  value As Variant
  Address As String
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private Works() As TypeArguments

Function S_FLATTEN(SORT As Integer, ParamArray Cells())
  On Error Resume Next
  Dim k%, i%, rg, s$, b(), cr&, adr$, f$
  Set rg = Application.ThisCell
  f = UCase(rg.Formula)
  If Not f Like "=@S_FLATTEN(*" And Not f Like "=S_FLATTEN(*" Then
    GoSub r: S_FLATTEN = b: Exit Function
  End If
  Select Case OfficeVersion
  Case 0, 2007, 2010, 2013, 2016, 2019:
    GoSub r
    S_FLATTEN = b(1, 1)
    adr = rg.Caller.Address(0, 0, external:=1)
    k = UBound(Works)
    For i = 1 To k
      With Works(i)
        If .Address = adr Then
          If .Action = 2 Then
            .Action = 3
            S_FLATTEN = .value
            Call SetTimer(0&, 0&, 0, AddressOf S_FLATTEN_Finally)
            Exit Function
          Else
            .Action = 0
          End If
          Exit For
        End If
      End With
    Next
    k = k + 1: ReDim Preserve Works(1 To k)
    With Works(k)
      Set .Caller = rg
      .results = b
      .Formula = f
      .Action = 0
      .rows = cr
      .value = b(1, 1)
      .Address = adr
    End With
    Call SetTimer(0&, 0&, 0, AddressOf S_FLATTEN_callback)
  Case Else: GoSub r: S_FLATTEN = b
  End Select
  On Error GoTo 0
Exit Function
r:
  GoSub g
  Select Case VBA.Sgn(SORT)
  Case 0:
  Case 1: Call FLATTENSort(b, 1, cr, 0, False)
  Case -1: Call FLATTENSort(b, 1, cr, -1, False)
  End Select
Return
g:
  Dim Data, area, r&, lr&, lc&, ur&, uc&, c&, a
  For Each Data In Cells
    Select Case TypeName(Data)
    Case "Range"
      For Each area In Data.Areas
        a = area.value
        If IsArray(a) Then GoSub c2 Else cr = cr + 1
      Next
    Case "Variant()": a = Data
      VBA.Err.Clear
      lr = LBound(a)
      If VBA.Err = 0 Then
        uc = UBound(a, 2)
        If VBA.Err Then
          GoSub c1
        Else
          GoSub c2
        End If
      End If
    Case Else: cr = cr + 1
    End Select
  Next
  If cr = 0 Then S_FLATTEN = "": Exit Function
  ReDim Preserve b(1 To cr, 1 To 1): cr = 0
  For Each Data In Cells
    Select Case TypeName(Data)
    Case "Range"
      For Each area In Data.Areas
        a = area.value
        If IsArray(a) Then GoSub r2 Else GoSub r1
      Next
    Case "Variant()": a = Data
      VBA.Err.Clear: lr = LBound(a)
      If VBA.Err = 0 Then
        uc = UBound(a, 2)
        If VBA.Err Then
          lr = LBound(a): ur = UBound(a) - lr + 1
          For r = 1 To ur
            b(cr + r, 1) = a(r + lr - 1)
          Next
          cr = cr + ur
        Else
          GoSub r2
        End If
      End If
    Case Else: GoSub r1
    End Select
  Next
Return
r1:
  cr = cr + 1:  b(cr, 1) = Data
Return
r2:
  lr = LBound(a, 1): ur = UBound(a, 1) - lr + 1
  lc = LBound(a, 2): uc = UBound(a, 2) - lc + 1
  For r = 1 To ur
    For c = 1 To uc
      b(cr + (r - 1) * ur + c, 1) = a(r + lr - 1, c + lc - 1)
    Next
  Next
  cr = cr + ur * uc
Return
c1:
  lr = LBound(a): cr = cr + UBound(a) - lr + 1
c2:
  lr = LBound(a, 1): ur = UBound(a, 1) - lr + 1
  lc = LBound(a, 2): uc = UBound(a, 2) - lc + 1
  cr = cr + ur * uc
Return

End Function

#If VBA7 And Win64 Then
Private Sub S_FLATTEN_Finally(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub S_FLATTEN_Finally(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub S_FLATTEN_Finally(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
' Last Edit: 08/02/2021 06:16
  On Error Resume Next
  KillTimer 0&, idEvent
  Dim UA%, i%, k%
  UA = UBound(Works)
  For i = 1 To UA
    Select Case Works(i).Action
    Case 3:
      k = k + 1
    End Select
n:
  Next
  If k >= UA Then Erase Works
  On Error GoTo 0
End Sub

#If VBA7 And Win64 Then
Private Sub S_FLATTEN_callback(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub S_FLATTEN_callback(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub S_FLATTEN_callback(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
' Last Edit: 08/02/2021 06:16
  On Error Resume Next
  KillTimer 0&, idEvent
  S_FLATTEN_working
  On Error GoTo 0
End Sub

Private Sub S_FLATTEN_working()
  Dim lr&, UA%, MS, i&, a As Object, b As TypeArguments, ee As Boolean, su As Boolean, ac As Long
  
  On Error Resume Next
  UA = UBound(Works)
  For i = 1 To UA
    b = Works(i)
    Select Case b.Action
    Case 0
      Works(i).Action = 1
      If UCase(b.Caller.Formula) = b.Formula Then
        lr = b.Caller.Parent.UsedRange.rows.count
        If a Is Nothing Then
          Set a = ws.Parent.Parent
          ee = Application.EnableEvents
          su = a.ScreenUpdating
          ac = a.Calculation
          If ee Then a.EnableEvents = False
          If su Then a.ScreenUpdating = False
          If ac <> xlCalculationManual Then a.Calculation = xlCalculationManual
        End If
        b.Caller.Resize(lr - b.Caller.Row).ClearContents
        b.Caller.Resize(b.rows).value = b.results
        Works(i).Action = 2
        b.Caller.Formula = b.Formula
      End If
      Works(i).Action = 2
    End Select
n:
  Next
  If Not a Is Nothing Then
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> ac Then a.Calculation = ac
    Set a = Nothing
  End If
  On Error GoTo 0
End Sub

Private Sub FLATTENSort( _
              SortArray, _
             ByVal Low&, _
             ByVal Hight&, _
    Optional ByVal Desending As Boolean, _
    Optional ByVal MatchCase As Boolean)
    
  Dim Lo&, Hi&, m, s
  If Not Desending Then
    Do
      Lo = Low: Hi = Hight
      m = SortArray((Lo + Hi) \ 2, 1)
      Do
        While CompText(SortArray(Lo, 1), m, MatchCase, False) = -1: Lo = Lo + 1: Wend
        While CompText(SortArray(Hi, 1), m, MatchCase, False) = 1: Hi = Hi - 1: Wend
        If Lo <= Hi Then
          s = SortArray(Lo, 1): SortArray(Lo, 1) = SortArray(Hi, 1): SortArray(Hi, 1) = s
          Lo = Lo + 1: Hi = Hi - 1
        End If
      Loop Until Lo > Hi
      If Hi > Low Then FLATTENSort SortArray, Low, Hi, Desending, MatchCase
      Low = Lo
    Loop Until Lo >= Hight
  Else
    Do
      Lo = Low: Hi = Hight
      m = SortArray((Lo + Hi) \ 2, 1)
      Do
        While CompText(SortArray(Lo, 1), m, MatchCase, True) = 1: Lo = Lo + 1: Wend
        While CompText(SortArray(Hi, 1), m, MatchCase, True) = -1: Hi = Hi - 1: Wend
        If Lo <= Hi Then
          s = SortArray(Lo, 1): SortArray(Lo, 1) = SortArray(Hi, 1): SortArray(Hi, 1) = s
          Lo = Lo + 1: Hi = Hi - 1
        End If
      Loop Until Lo > Hi
      If Hi > Low Then FLATTENSort SortArray, Low, Hi, Desending, MatchCase
      Low = Lo
    Loop Until Lo >= Hight
  End If
End Sub


Private Sub CompText_test()
  Debug.Print CompText(1, 2), "(1, 2)"
  Debug.Print CompText(1, #11:11:11 AM#)
  Debug.Print CompText("c", "C", True)
  Debug.Print CompText("c", "C3", True)
End Sub
Private Function CompText(ByVal Text1$, ByVal Text2$, Optional ByVal MatchCase As Boolean = True, Optional ByVal SortDescending As Boolean) As Integer
  If Text1 = Text2 Then
    CompText = 0
  ElseIf Text1 = vbNullString Then
    CompText = IIf(SortDescending, -1, 1)
  ElseIf Text2 = vbNullString Then
    CompText = IIf(SortDescending, 1, -1)
  Else
    Dim n1 As Boolean, N2 As Boolean
    n1 = IsNumeric(Text1) Or IsDate(Text1)
    N2 = IsNumeric(Text2) Or IsDate(Text2)
    If (n1 And N2) Then
      If Text1 = Text2 Then
        CompText = 0
      ElseIf CDec(CDate(Text1)) < CDec(CDate(Text2)) Then
        CompText = -1
      Else
        CompText = 1
      End If
    ElseIf (n1 And Not N2) Then
      CompText = -1:
    ElseIf (Not n1 And N2) Then
      CompText = 1:
    Else
      Dim l1&, l2&, l&, b As Integer, i&
      l1 = Len(Text1): l2 = Len(Text2)
      l = IIf(l1 < l2, l1, l2)
      For i = 1 To l
        b = StrComp(Mid(Text1, i, 1), Mid(Text2, i, 1), 1 + MatchCase)
        If b <> 0 Then CompText = b: Exit Function
      Next
      If l1 < l2 Then
        CompText = -1
      ElseIf l1 = l2 Then
        CompText = 0
      Else
        CompText = 1
      End If
    End If
  End If
End Function


Private Function OfficeVersion() As Long
  Dim registryObject As Object
  Dim rootDirectory As String
  Dim keyPath As String
  Dim arrEntryNames As Variant
  Dim arrValueTypes As Variant
  Dim x As Long
  Select Case Val(Application.Version)
  Case Is = 16
    'Check for existence of Licensing key
    
    keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
    rootDirectory = "."
    Set registryObject = VBA.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
    registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
    On Error GoTo ErrorExit
    For x = 0 To UBound(arrEntryNames)
      If InStr(arrEntryNames(x), "365") > 0 Then
        OfficeVersion = 365
        Exit Function
      End If
      If InStr(arrEntryNames(x), "2019") > 0 Then
        If Application.Build >= 14332 Then
          'ProductCode: {90160000-000F-0000-1000-0000000FF1CE}
          'CalculationVersion:  191029
          OfficeVersion = 2021
        Else
          OfficeVersion = 2019
        End If
        Exit Function
      End If
      If InStr(arrEntryNames(x), "2016") > 0 Then
        OfficeVersion = 2016
        Exit Function
      End If
    Next x
  Case Is = 15: OfficeVersion = 2013
  Case Is = 14: OfficeVersion = 2010
        'ProductCode: {91140000-0011-0000-1000-0000000FF1CE}
        'CalculationVersion:  145621
  Case Is = 12: OfficeVersion = 2007
  Case Else: OfficeVersion = 0
  End Select
  Exit Function
ErrorExit:
  'Version 16, but no licensing key. Must be Office 2016
  OfficeVersion = 2016
End Function

Tình nghĩa giang hồ · 2/6/22

HeSanbi đã viết:

Flatten Google Sheet + Sort

=S_FLATTEN(0,A1:B4,"Hello",1,E5:G9)
=S_FLATTEN(1,A1:B4,"Hello",1,E5:G9)
=S_FLATTEN(-1,A1:B4,"Hello",1,E5:G9)

JavaScript:

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Caller As Range
  results As Variant
  rows As Long
  value As Variant
  Address As String
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private Works() As TypeArguments

Function S_FLATTEN(SORT As Integer, ParamArray Cells())
  On Error Resume Next
  Dim k%, i%, rg, s$, b(), cr&, adr$, f$
  Set rg = Application.ThisCell
  f = UCase(rg.Formula)
  If Not f Like "=@S_FLATTEN(*" And Not f Like "=S_FLATTEN(*" Then
    GoSub r: S_FLATTEN = b: Exit Function
  End If
  Select Case OfficeVersion
  Case 0, 2007, 2010, 2013, 2016, 2019:
    GoSub r
    S_FLATTEN = b(1, 1)
    adr = rg.Caller.Address(0, 0, external:=1)
    k = UBound(Works)
    For i = 1 To k
      With Works(i)
        If .Address = adr Then
          If .Action = 2 Then
            .Action = 3
            S_FLATTEN = .value
            Call SetTimer(0&, 0&, 0, AddressOf S_FLATTEN_Finally)
            Exit Function
          Else
            .Action = 0
          End If
          Exit For
        End If
      End With
    Next
    k = k + 1: ReDim Preserve Works(1 To k)
    With Works(k)
      Set .Caller = rg
      .results = b
      .Formula = f
      .Action = 0
      .rows = cr
      .value = b(1, 1)
      .Address = adr
    End With
    Call SetTimer(0&, 0&, 0, AddressOf S_FLATTEN_callback)
  Case Else: GoSub r: S_FLATTEN = b
  End Select
  On Error GoTo 0
Exit Function
r:
  GoSub g
  Select Case VBA.Sgn(SORT)
  Case 0:
  Case 1: Call FLATTENSort(b, 1, cr, 0, False)
  Case -1: Call FLATTENSort(b, 1, cr, -1, False)
  End Select
Return
g:
  Dim Data, area, r&, lr&, lc&, ur&, uc&, c&, a
  For Each Data In Cells
    Select Case TypeName(Data)
    Case "Range"
      For Each area In Data.Areas
        a = area.value
        If IsArray(a) Then GoSub c2 Else cr = cr + 1
      Next
    Case "Variant()": a = Data
      VBA.Err.Clear
      lr = LBound(a)
      If VBA.Err = 0 Then
        uc = UBound(a, 2)
        If VBA.Err Then
          GoSub c1
        Else
          GoSub c2
        End If
      End If
    Case Else: cr = cr + 1
    End Select
  Next
  If cr = 0 Then S_FLATTEN = "": Exit Function
  ReDim Preserve b(1 To cr, 1 To 1): cr = 0
  For Each Data In Cells
    Select Case TypeName(Data)
    Case "Range"
      For Each area In Data.Areas
        a = area.value
        If IsArray(a) Then GoSub r2 Else GoSub r1
      Next
    Case "Variant()": a = Data
      VBA.Err.Clear: lr = LBound(a)
      If VBA.Err = 0 Then
        uc = UBound(a, 2)
        If VBA.Err Then
          lr = LBound(a): ur = UBound(a) - lr + 1
          For r = 1 To ur
            b(cr + r, 1) = a(r + lr - 1)
          Next
          cr = cr + ur
        Else
          GoSub r2
        End If
      End If
    Case Else: GoSub r1
    End Select
  Next
Return
r1:
  cr = cr + 1:  b(cr, 1) = Data
Return
r2:
  lr = LBound(a, 1): ur = UBound(a, 1) - lr + 1
  lc = LBound(a, 2): uc = UBound(a, 2) - lc + 1
  For r = 1 To ur
    For c = 1 To uc
      b(cr + (r - 1) * ur + c, 1) = a(r + lr - 1, c + lc - 1)
    Next
  Next
  cr = cr + ur * uc
Return
c1:
  lr = LBound(a): cr = cr + UBound(a) - lr + 1
c2:
  lr = LBound(a, 1): ur = UBound(a, 1) - lr + 1
  lc = LBound(a, 2): uc = UBound(a, 2) - lc + 1
  cr = cr + ur * uc
Return

End Function

#If VBA7 And Win64 Then
Private Sub S_FLATTEN_Finally(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub S_FLATTEN_Finally(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub S_FLATTEN_Finally(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
' Last Edit: 08/02/2021 06:16
  On Error Resume Next
  KillTimer 0&, idEvent
  Dim UA%, i%, k%
  UA = UBound(Works)
  For i = 1 To UA
    Select Case Works(i).Action
    Case 3:
      k = k + 1
    End Select
n:
  Next
  If k >= UA Then Erase Works
  On Error GoTo 0
End Sub

#If VBA7 And Win64 Then
Private Sub S_FLATTEN_callback(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub S_FLATTEN_callback(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub S_FLATTEN_callback(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
' Last Edit: 08/02/2021 06:16
  On Error Resume Next
  KillTimer 0&, idEvent
  S_FLATTEN_working
  On Error GoTo 0
End Sub

Private Sub S_FLATTEN_working()
  Dim UA%, MS, i&, a As Object, b As TypeArguments, ee As Boolean, su As Boolean, ac As Long
  On Error Resume Next
  UA = UBound(Works)
  For i = 1 To UA
    b = Works(i)
    Select Case b.Action
    Case 0
      Works(i).Action = 1
      If UCase(b.Caller.Formula) = b.Formula Then
        If a Is Nothing Then
          Set a = b.Caller.Parent.Parent.Parent
          ee = Application.EnableEvents
          su = a.ScreenUpdating
          ac = a.Calculation
          If ee Then a.EnableEvents = False
          If su Then a.ScreenUpdating = False
          If ac <> xlCalculationManual Then a.Calculation = xlCalculationManual
        End If
        b.Caller.Resize(b.rows).value = b.results
        Works(i).Action = 2
        b.Caller.Formula = b.Formula
      End If
      Works(i).Action = 2
    End Select
n:
  Next
  If Not a Is Nothing Then
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac And a.Calculation <> ac Then a.Calculation = ac
    Set a = Nothing
  End If
  On Error GoTo 0
End Sub

Private Sub FLATTENSort( _
              SortArray, _
             ByVal Low&, _
             ByVal Hight&, _
    Optional ByVal Desending As Boolean, _
    Optional ByVal MatchCase As Boolean)
 
  Dim Lo&, Hi&, m, s
  If Not Desending Then
    Do
      Lo = Low: Hi = Hight
      m = SortArray((Lo + Hi) \ 2, 1)
      Do
        While CompText(SortArray(Lo, 1), m, MatchCase, False) = -1: Lo = Lo + 1: Wend
        While CompText(SortArray(Hi, 1), m, MatchCase, False) = 1: Hi = Hi - 1: Wend
        If Lo <= Hi Then
          s = SortArray(Lo, 1): SortArray(Lo, 1) = SortArray(Hi, 1): SortArray(Hi, 1) = s
          Lo = Lo + 1: Hi = Hi - 1
        End If
      Loop Until Lo > Hi
      If Hi > Low Then FLATTENSort SortArray, Low, Hi, Desending, MatchCase
      Low = Lo
    Loop Until Lo >= Hight
  Else
    Do
      Lo = Low: Hi = Hight
      m = SortArray((Lo + Hi) \ 2, 1)
      Do
        While CompText(SortArray(Lo, 1), m, MatchCase, True) = 1: Lo = Lo + 1: Wend
        While CompText(SortArray(Hi, 1), m, MatchCase, True) = -1: Hi = Hi - 1: Wend
        If Lo <= Hi Then
          s = SortArray(Lo, 1): SortArray(Lo, 1) = SortArray(Hi, 1): SortArray(Hi, 1) = s
          Lo = Lo + 1: Hi = Hi - 1
        End If
      Loop Until Lo > Hi
      If Hi > Low Then FLATTENSort SortArray, Low, Hi, Desending, MatchCase
      Low = Lo
    Loop Until Lo >= Hight
  End If
End Sub


Private Sub CompText_test()
  Debug.Print CompText(1, 2), "(1, 2)"
  Debug.Print CompText(1, #11:11:11 AM#)
  Debug.Print CompText("c", "C", True)
  Debug.Print CompText("c", "C3", True)
End Sub
Private Function CompText(ByVal Text1$, ByVal Text2$, Optional ByVal MatchCase As Boolean = True, Optional ByVal SortDescending As Boolean) As Integer
  If Text1 = Text2 Then
    CompText = 0
  ElseIf Text1 = vbNullString Then
    CompText = IIf(SortDescending, -1, 1)
  ElseIf Text2 = vbNullString Then
    CompText = IIf(SortDescending, 1, -1)
  Else
    Dim n1 As Boolean, N2 As Boolean
    n1 = IsNumeric(Text1) Or IsDate(Text1)
    N2 = IsNumeric(Text2) Or IsDate(Text2)
    If (n1 And N2) Then
      If Text1 = Text2 Then
        CompText = 0
      ElseIf CDec(CDate(Text1)) < CDec(CDate(Text2)) Then
        CompText = -1
      Else
        CompText = 1
      End If
    ElseIf (n1 And Not N2) Then
      CompText = -1:
    ElseIf (Not n1 And N2) Then
      CompText = 1:
    Else
      Dim l1&, l2&, l&, m1$, m2$, b As Integer, i&
      l1 = Len(Text1): l2 = Len(Text2)
      l = IIf(l1 < l2, l1, l2)
      For i = 1 To l
        m1 = Mid(Text1, i, 1): m2 = Mid(Text2, i, 1)
        b = StrComp(m1, m2, 1 + MatchCase)
        If b <> 0 Then CompText = b: Exit Function
        If i = l Then
          If l1 < l2 Then
            CompText = -1
          ElseIf l1 = l2 Then
            CompText = 0
          Else
            CompText = 1
          End If
        End If
      Next
    End If
  End If
End Function


Private Function OfficeVersion() As Long
  Dim registryObject As Object
  Dim rootDirectory As String
  Dim keyPath As String
  Dim arrEntryNames As Variant
  Dim arrValueTypes As Variant
  Dim x As Long
  Select Case Val(Application.Version)
  Case Is = 16
    'Check for existence of Licensing key
 
    keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
    rootDirectory = "."
    Set registryObject = VBA.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
    registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
    On Error GoTo ErrorExit
    For x = 0 To UBound(arrEntryNames)
      If InStr(arrEntryNames(x), "365") > 0 Then
        OfficeVersion = 365
        Exit Function
      End If
      If InStr(arrEntryNames(x), "2019") > 0 Then
        If Application.Build >= 14332 Then
          'ProductCode: {90160000-000F-0000-1000-0000000FF1CE}
          'CalculationVersion:  191029
          OfficeVersion = 2021
        Else
          OfficeVersion = 2019
        End If
        Exit Function
      End If
      If InStr(arrEntryNames(x), "2016") > 0 Then
        OfficeVersion = 2016
        Exit Function
      End If
    Next x
  Case Is = 15: OfficeVersion = 2013
  Case Is = 14: OfficeVersion = 2010
        'ProductCode: {91140000-0011-0000-1000-0000000FF1CE}
        'CalculationVersion:  145621
  Case Is = 12: OfficeVersion = 2007
  Case Else: OfficeVersion = 0
  End Select
  Exit Function
ErrorExit:
  'Version 16, but no licensing key. Must be Office 2016
  OfficeVersion = 2016
End Function

Hay quá anh ơi, em đã làm được rồi. Cảm ơn anh HeSanbi, Johnnylinhanh và các anh em nhiều nhé.

HeSanbi · 2/6/22

Tình nghĩa giang hồ đã viết:
Hay quá anh ơi, em đã làm được rồi. Cảm ơn anh HeSanbi, Johnnylinhanh và các anh em nhiều nhé.

Có chút lỗi tôi đã sửa bạn tải lại mã

Hỗ trợ hàm UDF sao y bản chính FLATTEN

Thanh sơn bất cải, lục thủy trường lưu

File đính kèm

Thành viên gạo cội

Thành viên gạo cội

Ăn cùng góc phố

Thành viên thường trực

File đính kèm

Thành viên gạo cội

Ăn cùng góc phố

Thành viên thường trực

Ăn cùng góc phố

|||||||||||||

Thành viên thường trực

Ăn cùng góc phố

Thành viên thường trực

Đăng ký hôm qua

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

File đính kèm

Thanh sơn bất cải, lục thủy trường lưu

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨