Công thức thì chịu, dùng sub này xem sao
Public Sub TH_Phep()
Dim DL, Tam, Nghi(), r As Long
DL = Sheet2.Range("A3", Sheet2.Range("K65000").End(xlUp))
With CreateObject("scripting.dictionary")
For r = 2 To UBound(DL)
If DL(r, 6) = "" Then
Tam = DL(r, 4)
Else
Tam = DL(r, 4) & "(" & DL(r, 6) & ")"
End If
If Not .exists(DL(r, 1)) Then
Nghi = Array(DL(r, 7), Tam)
.Add DL(r, 1), Nghi
Else
Nghi = .Item(DL(r, 1))
Nghi(1) = Nghi(1) & ";" & Tam
.Item(DL(r, 1)) = Nghi
End If
Next r
Tam = Application.Transpose(.keys)
ReDim Nghi(1 To .Count, 1 To 2)
For r = 1 To UBound(Tam)
Nghi(r, 1) = .Item(Tam(r, 1))(0)
Nghi(r, 2) = .Item(Tam(r, 1))(1)
Next r
End With
Sheet1.Range("A2").Resize(UBound(Tam), 1).Value = Tam
Sheet1.Range("B2").Resize(UBound(Nghi), 2).Value = Nghi
End Sub
Option Explicit
Function DGFep(Ma As Long, Rng As Range)
Dim sRng As Range, Cls As Range, Rg0 As Range
Dim J As Long, Rws As Long
Const Nua As String = "(0,5)"
Const KN As String = "; "
Set sRng = Rng.Find(Ma, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Set Rg0 = sRng.Resize(Rng.Rows.Count)
For Each Cls In Rg0
If Cls.Value = "" Then Exit For
If Ma = Cls.Value Then
DGFep = DGFep & KN & CStr(Cls.Offset(, 1).Value) & IIf(Cls.Offset(, 5).Value = 0.5, Nua, "")
End If
Next Cls
End If
DGFep = Mid(DGFep, 2, 99)
End Function
Thêm một hàm tự tạo:
