Nhờ các cao thủ giúp đỡ công thức lọc, tách. (1 người xem)

nguyenkar · 21/10/22

Mình dính một đề bài xếp loại học sinh có 2 điều kiện như file ví dụ. Mong các cao thủ giúp đỡ công thức hàm excel ạ. Hoặc vba cũng được, làm sao cho đơn giản nhất ạ. Cảm ơn các bạn.

Phuocam · 21/10/22

nguyenkar đã viết:
Mình dính một đề bài xếp loại học sinh có 2 điều kiện như file ví dụ. Mong các cao thủ giúp đỡ công thức hàm excel ạ. Hoặc vba cũng được, làm sao cho đơn giản nhất ạ. Cảm ơn các bạn.

.

Yêu cầu đầu tiên là kết quả phải đúng, sau đó mới tính chuyện rút gọn công thức.

Công thức bạn đang làm là gì?

.

bebo021999 · 21/10/22

VBA nhé.
Click chuột phải vào tên sheet, View Code rồi dán code này vào.
Chọn các giá trị tại ô M3:

Mã:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "M3" Then Exit Sub
Dim lr&, i&, j&, k&, g&, rng, arr()
lr = Cells(Rows.Count, "B").End(xlUp).Row
g = WorksheetFunction.CountIf(Range("C4:G" & lr), Target)
ReDim arr(1 To g, 1 To 2)
rng = Range("B3:G" & lr).Value
For i = 2 To UBound(rng)
    For j = 2 To UBound(rng, 2)
        If rng(i, j) Like Target Then
            k = k + 1
            arr(k, 1) = rng(i, 1)
            arr(k, 2) = rng(1, j)
        End If
    Next
Next
Range("L6:M10000").ClearContents
Range("L6").Resize(UBound(arr), 2).Value = arr
End Sub

SA_DQ · 21/10/22

Bạn xem file mình thực hiện bỡi macro sự kiện.

Ronaldinho7 · 21/10/22

nguyenkar đã viết:
Mình dính một đề bài xếp loại học sinh có 2 điều kiện như file ví dụ. Mong các cao thủ giúp đỡ công thức hàm excel ạ. Hoặc vba cũng được, làm sao cho đơn giản nhất ạ. Cảm ơn các bạn.

Bạn cứ xưng hô trân phương kiểu như Anh/Chị được rồi, không cần cao nhân... gì đâu nhé!

PHP:

Sub GPE()
    Dim Arr(), Res(), i As Long, j As Long, k As Long
    Dim Lr As Long
    On Error Resume Next
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B3:G" & Lr).Value
        ReDim Res(1 To UBound(Arr, 1) * 5, 1 To 2)
        For i = 2 To UBound(Arr, 1)
            For j = 2 To UBound(Arr, 2)
                If UCase(Arr(i, j)) = "GI" & ChrW(7886) & "I" Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(1, j)
                End If
            Next j
        Next i
        .Range("O6:P1000").ClearContents
        .Range("O6").Resize(k, 2).Value = Res
    End With
End Sub

nguyenkar · 21/10/22

Bienhoa84 đã viết:
Bạn cứ xưng hô trân phương kiểu như Anh/Chị được rồi, không cần cao nhân... gì đâu nhé!

Vâng ạ, rất cảm ơn anh chị đã giúp đỡ. Code chạy rất ok ạ. Mình còn 1 vấn đề nữa mong các a.c giúp luôn ạ.
Mình muốn kết quả sẽ nằm ở 1 sheet khác, mỗi loại học sinh nằm sang 1 sheet khác nhau thì phải làm thế nào ạ.

snow25 · 21/10/22

bebo021999 đã viết:

VBA nhé.
Click chuột phải vào tên sheet, View Code rồi dán code này vào.
Chọn các giá trị tại ô M3:

Mã:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "M3" Then Exit Sub
Dim lr&, i&, j&, k&, g&, rng, arr()
lr = Cells(Rows.Count, "B").End(xlUp).Row
g = WorksheetFunction.CountIf(Range("C4:G" & lr), Target)
ReDim arr(1 To g, 1 To 2)
rng = Range("B3:G" & lr).Value
For i = 2 To UBound(rng)
    For j = 2 To UBound(rng, 2)
        If rng(i, j) Like Target Then
            k = k + 1
            arr(k, 1) = rng(i, 1)
            arr(k, 2) = rng(1, j)
        End If
    Next
Next
Range("L6:M10000").ClearContents
Range("L6").Resize(UBound(arr), 2).Value = arr
End Sub

Tại sao lại sử dụng hàm countif tìm kiếm tuyệt đối.Rồi lấy để chọn kích thước mảng cho tìm kiếm tương đối anh.

87kilua · 21/10/22

Thứ đơn giản lại là thứ phức tạp nhất.

Dành cho fan No VBA

SA_DQ · 21/10/22

nguyenkar đã viết:
. . . . . .. Mình còn 1 vấn đề nữa mong các a.c giúp luôn ạ.
Mình muốn kết quả sẽ nằm ở 1 sheet khác, mỗi loại học sinh nằm sang 1 sheet khác nhau thì phải làm thế nào ạ.

(Theo tiếp í tưởng #4) thì mỗi trang tính cần thiết danh sách 1 loại kết quả học lực nào đó của HS ta nên để macro sự kiện khi kích hoạt trang tính đó
Ta thêm sự kiện khi kích hoạt trang tính như sau:

PHP:

Private Sub Worksheet_Activate()
 GPE [M3].Value
End Sub

Ở đây ô m3 của trang tính ghi giá trị cần tìm, như 'Trung bình', . . .

Còn ở module1 ta lập macro con & trao cho nó tham biến cần tình (là giá trị đang chứa trong [M3] kia, ví dụ:

Mã:

Sub GPE(HL As String)
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String:                       Dim W As Integer
 
 With Sheet1
    Set Rng = .[c3].CurrentRegion
    [L6].CurrentRegion.Offset(1).ClearContents
    W = Rng.Cells.Count
    ReDim Arr(1 To W, 1 To 2) As String:    W = 0
6    Set sRng = Rng.Find(HL, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1
            Arr(W, 1) = .Cells(sRng.Row, "B").Value
            Arr(W, 2) = .Cells(3, sRng.Column).Value
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
    [L6].Resize(W, 2).Value = Arr():        Randomize
    [L5:M5].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
 End With
End Sub

Bạn đối chiếu giữa macro con này với macro trong #4 xem có gì thú vị với bạn không!

DongACB · 21/10/22

Toàn cao thủ lập trình. Ngưỡng mộ

Nhattanktnn · 22/10/22

nguyenkar đã viết:
Mình dính một đề bài xếp loại học sinh có 2 điều kiện như file ví dụ. Mong các cao thủ giúp đỡ công thức hàm excel ạ. Hoặc vba cũng được, làm sao cho đơn giản nhất ạ. Cảm ơn các bạn.

Thử công thức dưới:

Less:

L6=IFERROR(INDEX($B$4:$B$14,AGGREGATE(15,6,(ROW($B$4:$B$14)-3)/($C$4:$G$14="Giỏi"),ROW(A1))),"")
M6=IFERROR(INDEX($C$3:$G$3,AGGREGATE(15,6,(COLUMN($C$3:$G$3)-2)/(INDEX($C$4:$G$14,MATCH(L6,$B$4:$B$14,0),)="Giỏi"),COUNTIF($L$6:L6,L6))),"")

huhumalu · 22/10/22

Cứ nghe thấy chữ cao thủ là vào chỉ dám đọc, không dám ho luôn.

ptm0412 · 22/10/22

Thứ phức tạp nhất trở thành đơn giản nhất với PQ. Dành cho fan hâm mộ Power query

PHP:

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Unpivot1 = Table.UnpivotOtherColumns(Source, {"Tên Học Viên"}, "Năm đạt giỏi", "Value"),
    SelectA = Table.SelectRows(Unpivot1, each ([Value] = "Giỏi")),
    RemoveA = Table.RemoveColumns(SelectA,{"Value"})
in
    RemoveA

befaint · 22/10/22

Query Google Sheets nhẹ nhàng nữa cơ.

VetMini · 22/10/22

huhumalu đã viết:
Cứ nghe thấy chữ cao thủ là vào chỉ dám đọc, không dám ho luôn.

Không biết những người hay dùng từ ngữ loại này có bao giờ nhờ các đồng nghiệp cùng phòng, hay cùng cơ quan:
- Có cao thủ nào chỉ giáo giùm em...
Hay vào cơ quan bạn, chào cô ngồi phòng lễ tân (cô này cũng cỡ trên 30 một tý, chứ chẳng lẽ cứ đến sinh nhật 30 thì đuổi người ta):
- Kính chào chư vị tiền bối...

Vè nhà, lên mạng xã hội than:
mh chào hỏi, dg toàn từ "tôn kính". Mà sao mn cứ chửi "đồ mất dạy".

Ronaldinho7 · 22/10/22

nguyenkar đã viết:
Vâng ạ, rất cảm ơn anh chị đã giúp đỡ. Code chạy rất ok ạ. Mình còn 1 vấn đề nữa mong các a.c giúp luôn ạ.
Mình muốn kết quả sẽ nằm ở 1 sheet khác, mỗi loại học sinh nằm sang 1 sheet khác nhau thì phải làm thế nào ạ.

Bạn có thể dùng code này

PHP:

Sub GPE()
    Dim Arr(), Res(), i As Long, j As Long, k As Long, Ws As Worksheet
    Dim Lr As Long, l As Long, m As Long, Res1(), Res2()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If Ws.Name <> "Sheet1" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B3:G" & Lr).Value
        ReDim Res(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res1(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res2(1 To UBound(Arr, 1) * 5, 1 To 2)
        For i = 2 To UBound(Arr, 1)
            For j = 2 To UBound(Arr, 2)
                If UCase(Arr(i, j)) = "GI" & ChrW(7886) & "I" Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "KHﾁ" Then
                    l = l + 1
                    Res1(l, 1) = Arr(i, 1)
                    Res1(l, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "TRUNG BﾌNH" Then
                    m = m + 1
                    Res2(m, 1) = Arr(i, 1)
                    Res2(m, 2) = Arr(1, j)
                
                End If
            Next j
        Next i
        If k Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "GI" & ChrW(7886) & "I"
            ActiveSheet.Range("B2").Resize(k, 2).Value = Res
        End If
        If l Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "KHﾁ"
            ActiveSheet.Range("B2").Resize(l, 2).Value = Res1
        End If
        If m Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "TRUNG BﾌNH"
            ActiveSheet.Range("B2").Resize(m, 2).Value = Res2
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Ho瀟 th瀟h"
End Sub

nguyenkar · 27/10/22

Bienhoa84 đã viết:

Bạn có thể dùng code này

PHP:

Sub GPE()
    Dim Arr(), Res(), i As Long, j As Long, k As Long, Ws As Worksheet
    Dim Lr As Long, l As Long, m As Long, Res1(), Res2()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If Ws.Name <> "Sheet1" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B3:G" & Lr).Value
        ReDim Res(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res1(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res2(1 To UBound(Arr, 1) * 5, 1 To 2)
        For i = 2 To UBound(Arr, 1)
            For j = 2 To UBound(Arr, 2)
                If UCase(Arr(i, j)) = "GI" & ChrW(7886) & "I" Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "KHﾁ" Then
                    l = l + 1
                    Res1(l, 1) = Arr(i, 1)
                    Res1(l, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "TRUNG BﾌNH" Then
                    m = m + 1
                    Res2(m, 1) = Arr(i, 1)
                    Res2(m, 2) = Arr(1, j)
             
                End If
            Next j
        Next i
        If k Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "GI" & ChrW(7886) & "I"
            ActiveSheet.Range("B2").Resize(k, 2).Value = Res
        End If
        If l Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "KHﾁ"
            ActiveSheet.Range("B2").Resize(l, 2).Value = Res1
        End If
        If m Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "TRUNG BﾌNH"
            ActiveSheet.Range("B2").Resize(m, 2).Value = Res2
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Ho瀟 th瀟h"
End Sub

Thanks bạn rất nhiều, nhưng sau 1 tuần vật vã với cái file này thì mình xin bó tay

. Vẫn phải học hỏi... gần như lại từ đầu ạ.
Code trên chạy ổn trong file với ít biến, nhiều hơn nữa máy mình đơ luôn, với lại khai báo thêm biến rất nhiều.

Code của anh mình ưng ý nhất nhưng khi áp dụng vào file mình làm thì không thành công, cái vấn đề là mình ngu lập trình nên đọc chỉ hiểu sơ sơ, không phát triển được.

bebo021999

Mấy a chị giúp e phát nữa, chứ e cũng đã thử đủ cách vẫn không hiểu được ạ, thử đủ cách mà không bắt được activate sheet nên có khi nó đè luôn lên sheet data - out of memory luôn

. Query của gg sheet thì e làm được nhưng cũng chỉ trong sheet đó thôi, nhảy qua sheet khác hoặc tạo theo kiểu nhấn từng cái trong combo box thì cũng k được.

File VB1 là file kết quả mình mong muốn, nhưng nếu làm bằng tay thì khi điều kiện cần lọc tăng, sẽ phải tách rất nhiều nút, nhiều ô lọc, và phải tách rất nhiều Sub ra nữa

. Anh chị nào gom được sub vào giúp e với nhé.

Ronaldinho7 · 27/10/22

nguyenkar đã viết:
Thanks bạn rất nhiều, nhưng sau 1 tuần vật vã với cái file này thì mình xin bó tay . Vẫn phải học hỏi... gần như lại từ đầu ạ.
Code trên chạy ổn trong file với ít biến, nhiều hơn nữa máy mình đơ luôn, với lại khai báo thêm biến rất nhiều.

Code của anh mình ưng ý nhất nhưng khi áp dụng vào file mình làm thì không thành công, cái vấn đề là mình ngu lập trình nên đọc chỉ hiểu sơ sơ, không phát triển được.

bebo021999

Mấy a chị giúp e phát nữa, chứ e cũng đã thử đủ cách vẫn không hiểu được ạ, thử đủ cách mà không bắt được activate sheet nên có khi nó đè luôn lên sheet data - out of memory luôn . Query của gg sheet thì e làm được nhưng cũng chỉ trong sheet đó thôi, nhảy qua sheet khác hoặc tạo theo kiểu nhấn từng cái trong combo box thì cũng k được.

Tôi nghĩ chắc bạn bị vướng hay nhầm lẫn chỗ nào đó thôi.
Nếu tiện bạn có thể gửi file gốc qua zalo, có thời gian tôi sẽ xem lại cho bạn!
thân!

nguyenkar · 27/10/22

Bienhoa84 đã viết:
Tôi nghĩ chắc bạn bị vướng hay nhầm lẫn chỗ nào đó thôi.
Nếu tiện bạn có thể gửi file gốc qua zalo, có thời gian tôi sẽ xem lại cho bạn!
thân!

PHP:

Sub Splitdatabycol()

'updateby Extendoffice

Dim lr As Long

Dim ws As Worksheet

Dim vcol, i As Integer

Dim icol As Long

Dim myarr As Variant

Dim title As String

Dim titlerow As Integer

Dim xTRg As Range

Dim xVRg As Range

Dim xWSTRg As Worksheet

Dim xWS As Worksheet

On Error Resume Next

Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)

If TypeName(xTRg) = "Nothing" Then Exit Sub

Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)

If TypeName(xVRg) = "Nothing" Then Exit Sub

vcol = xVRg.Column

Set ws = xTRg.Worksheet

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = xTRg.AddressLocal

titlerow = xTRg.Cells(1).Row

icol = ws.Columns.Count

ws.Cells(1, icol) = "Unique"

Application.DisplayAlerts = False

If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then

Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"

Else

Sheets("xTRgWs_Sheet").Delete

Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"

End If

Set xWSTRg = Sheets("xTRgWs_Sheet")

xTRg.Copy

xWSTRg.Paste Destination:=xWSTRg.Range("A1")

ws.Activate

For i = (titlerow + xTRg.Rows.Count) To lr

On Error Resume Next

If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then

ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)

End If

Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

ws.Columns(icol).Clear

For i = 2 To UBound(myarr)

ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then

Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))

xWS.Name = myarr(i) & ""

Else

xWS.Move after:=Worksheets(Worksheets.Count)

End If

xWSTRg.Range(title).Copy

xWS.Paste Destination:=xWS.Range("A1")

ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))

Sheets(myarr(i) & "").Columns.AutoFit

Next

xWSTRg.Delete

ws.AutoFilterMode = False

ws.Activate

Application.DisplayAlerts = True

End Sub

Mình tìm được 1 đoạn code này, dùng để tách sheets của Kutools. Bạn xem thử giúp nếu kết hợp với code của a bebo thì giải quyết dc không ạ?

bebo021999 · 27/10/22

Dùng đỡ cái này:

Mã:

Option Explicit
Sub xeploai()
Dim lr&, i&, j&, k&, rng
Dim ip As String, xL, xL2, dk As String, arr(1 To 100000, 1 To 2)
ip = InputBox(" Chon Xep Loai: (xs: xuat sac / g:gioi / k: kha / tb: trung binh / y: yeu)")
If Len(ip) = 0 Then Exit Sub
xL = Array("xs", "g", "k", "tb", "y")
xL2 = Array("xuat sac", "gioi", "kha", "trung binh", "yeu")
For i = 0 To UBound(xL)
    If ip = xL(i) Then
        dk = xL2(i)
        Exit For
    End If
Next
If dk = "" Then Exit Sub
With Sheets("data")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B4:H" & lr).Value
    For i = 2 To UBound(rng)
        For j = 2 To UBound(rng, 2)
            If Trim(rng(i, j)) Like dk Then
                k = k + 1
                arr(k, 1) = rng(i, 1)
                arr(k, 2) = rng(1, j)
            End If
        Next
    Next
End With
If Not Evaluate("=ISREF('" & dk & "'!A1)") Then
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = dk
        .Range("A1").Value = .Name
    End With
End If
Sheets(dk).Activate
Range("G8:H100000").ClearContents
Range("G8").Resize(k, 2).Value = arr
Range("G1:H1").EntireColumn.AutoFit
End Sub

nguyenkar · 27/10/22

bebo021999 đã viết:

Dùng đỡ cái này:

Mã:

Option Explicit
Sub xeploai()
Dim lr&, i&, j&, k&, rng
Dim ip As String, xL, xL2, dk As String, arr(1 To 100000, 1 To 2)
ip = InputBox(" Chon Xep Loai: (xs: xuat sac / g:gioi / k: kha / tb: trung binh / y: yeu)")
If Len(ip) = 0 Then Exit Sub
xL = Array("xs", "g", "k", "tb", "y")
xL2 = Array("xuat sac", "gioi", "kha", "trung binh", "yeu")
For i = 0 To UBound(xL)
    If ip = xL(i) Then
        dk = xL2(i)
        Exit For
    End If
Next
If dk = "" Then Exit Sub
With Sheets("data")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B4:H" & lr).Value
    For i = 2 To UBound(rng)
        For j = 2 To UBound(rng, 2)
            If Trim(rng(i, j)) Like dk Then
                k = k + 1
                arr(k, 1) = rng(i, 1)
                arr(k, 2) = rng(1, j)
            End If
        Next
    Next
End With
If Not Evaluate("=ISREF('" & dk & "'!A1)") Then
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = dk
        .Range("A1").Value = .Name
    End With
End If
Sheets(dk).Activate
Range("G8:H100000").ClearContents
Range("G8").Resize(k, 2).Value = arr
Range("G1:H1").EntireColumn.AutoFit
End Sub

E không biết nói gì hơn, cảm ơn anh rất nhiều

. Đúng là ăn mày được xôi gấc ạ. Code dễ hiểu, dễ thay đổi theo nhiều điều kiện phát sinh, còn ngắn gọn và chạy vô cùng đúng ý nữa. Thanks anh rất nhiều ạ.

LmoovoenX · 27/10/22

87kilua đã viết:
Thứ đơn giản lại là thứ phức tạp nhất.
View attachment 282362
Dành cho fan No VBA

Cách của bác rất hay, mình đã học được nhiều từ mấy hàm của bác.
Chỉ góp ý nhỏ xíu, chỗ lập mảng ở "Năm đạt loại giỏi", dùng hàm MID thì khi số lượng năm lớn hơn 10, VD từ năm 99 đến 2019 chẳng hạn, số thứ tự của cột nó là 2 chữ số mà Hàm MID chỉ lấy được 1 chữ số.
Mình dùng hàm textsplit như sau =INDEX(C3:G3,TEXTSPLIT(TEXTJOIN(";",1,IF(I4=C4:G14,COLUMN(C4:G14)-2,"")),,";")) đã giải quyết đc nó.

Nhattanktnn · 27/10/22

LmoovoenX đã viết:
Cách của bác rất hay, mình đã học được nhiều từ mấy hàm của bác.
Chỉ góp ý nhỏ xíu, chỗ lập mảng ở "Năm đạt loại giỏi", dùng hàm MID thì khi số lượng năm lớn hơn 10, VD từ năm 99 đến 2019 chẳng hạn, số thứ tự của cột nó là 2 chữ số mà Hàm MID chỉ lấy được 1 chữ số.
Mình dùng hàm textsplit như sau =INDEX(C3:G3,TEXTSPLIT(TEXTJOIN(";",1,IF(I4=C4:G14,COLUMN(C4:G14)-2,"")),,";")) đã giải quyết đc nó.

Office 365 bạn thử công thức này xem (dán công thức vào ô trống nào đó - File bài #1):

Mã:

=LET(ar,TOCOL(LET(a,B3:G14,MAP(a,LAMBDA(x,IF(x<>"Giỏi",NA(),INDEX(a,ROW(x)-2,1)&"|"&INDEX(a,1,COLUMN(x)-1))))),3),r,ROWS(ar),MAKEARRAY(r,2,LAMBDA(y,z,INDEX(TEXTSPLIT(INDEX(ar,y,1),"|"),,z))))

Hoặc phiên bản ngắn gọn hơn:

Mã:

=TEXTSPLIT(TEXTJOIN("`",1,LET(a,B3:G14,MAP(a,LAMBDA(x,IF(x<>"Giỏi","",INDEX(a,ROW(x)-2,1)&"|"&INDEX(a,1,COLUMN(x)-1)))))),"|","`")

nguyenkar · 1/11/22

bebo021999 đã viết:

Dùng đỡ cái này:

Mã:

Option Explicit
Sub xeploai()
Dim lr&, i&, j&, k&, rng
Dim ip As String, xL, xL2, dk As String, arr(1 To 100000, 1 To 2)
ip = InputBox(" Chon Xep Loai: (xs: xuat sac / g:gioi / k: kha / tb: trung binh / y: yeu)")
If Len(ip) = 0 Then Exit Sub
xL = Array("xs", "g", "k", "tb", "y")
xL2 = Array("xuat sac", "gioi", "kha", "trung binh", "yeu")
For i = 0 To UBound(xL)
    If ip = xL(i) Then
        dk = xL2(i)
        Exit For
    End If
Next
If dk = "" Then Exit Sub
With Sheets("data")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B4:H" & lr).Value
    For i = 2 To UBound(rng)
        For j = 2 To UBound(rng, 2)
            If Trim(rng(i, j)) Like dk Then
                k = k + 1
                arr(k, 1) = rng(i, 1)
                arr(k, 2) = rng(1, j)
            End If
        Next
    Next
End With
If Not Evaluate("=ISREF('" & dk & "'!A1)") Then
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = dk
        .Range("A1").Value = .Name
    End With
End If
Sheets(dk).Activate
Range("G8:H100000").ClearContents
Range("G8").Resize(k, 2).Value = arr
Range("G1:H1").EntireColumn.AutoFit
End Sub

Anh bebo cho em hỏi với cùng 1 cách này, mình không tạo sheet mới nữa, mà tạo workbook mới (tên wb và tên sheet mới tạo ra giống nhau) được không ạ? E có khai báo thêm 2 Function và sửa code tạo sheet thành như ở dưới mà chạy toàn bị báo lỗi out of range hoặc type missmath ko à.

Mã:

Option Explicit
Sub xeploai()
Dim lr&, i&, j&, k&, rng, sFileName As String, wb As Workbook, oldWb As Workbook, sWbName As Workbook, 
Dim ip As String, xL, xL2, dk As String, arr(1 To 100000, 1 To 2)
ip = InputBox(" Chon Xep Loai: (xs: xuat sac / g:gioi / k: kha / tb: trung binh / y: yeu)")
If Len(ip) = 0 Then Exit Sub
xL = Array("xs", "g", "k", "tb", "y")
xL2 = Array("xuat sac", "gioi", "kha", "trung binh", "yeu")
For i = 0 To UBound(xL)
    If ip = xL(i) Then
        dk = xL2(i)
        Exit For
    End If
Next
If dk = "" Then Exit Sub
oldWb.Activate
With Sheets("data")
    sFileName = dk & ".xlsx"
        If Not GetWb(sFileName, wb) & Evaluate("=ISREF('" & dk & "'!A1)") Then
            Set wb = CreateNewWb(sFileName)
            wb.Sheets.Add after:=Sheets(Sheets.Count)
                     With ActiveSheet
                             .Name = dk
                             .Range("A1").Value = .Name
                     End With
            oldWb.Activate
        End If
lr = .Cells(Rows.Count, "B").End(xlUp).Row
rng = .Range("B4:H" & lr).Value
    For i = 2 To UBound(rng)
        For j = 2 To UBound(rng, 2)
            If Trim(rng(i, j)) Like dk Then
                k = k + 1
                arr(k, 1) = rng(i, 1)
                arr(k, 2) = rng(1, j)
            End If
        Next
    Next
End With

sWbName.Sheets(dk).Activate
Range("G8:H100000").ClearContents
Range("G8").Resize(k, 2).Value = arr
Range("G1:H1").EntireColumn.AutoFit

lbFinally:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationSemiautomatic

    If Err <> 0 Then
        MsgBox Err.Description, vbCritical
    End If
    
End Sub

Function GetWb(sWbName As String, wb As Workbook) As Boolean
    Dim dk As Long
    'sWbName = LCase(sWbName)
    For G = 1 To Workbooks.Count
        If Workbooks(G).Name = sWbName Then
            GetWb = True
            Set wb = Workbooks(G)
            Exit Function
        End If
    Next G
End Function

Function CreateNewWb(sWbName As String) As Workbook
    Dim oldWb As Workbook
    Set oldWb = ActiveWorkbook
    Set CreateNewWb = Workbooks.Add
    CreateNewWb.SaveAs sWbName
    oldWb.Activate
End Function

Nhờ các cao thủ giúp đỡ công thức lọc, tách. (1 người xem)

Người dùng đang xem chủ đề này

Thành viên mới

File đính kèm

Thành viên mới

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

File đính kèm

/(hông là gì!

File đính kèm

Zl: 0707315985

File đính kèm

Thành viên mới

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

Thành viên hoạt động

File đính kèm

/(hông là gì!

Thành viên mới

Thành viên gắn bó

Thành viên tích cực

Bad Excel Member

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

Đang đi tìm hòn đá

Zl: 0707315985

File đính kèm

Thành viên mới

bebo021999​

​

File đính kèm

Zl: 0707315985

bebo021999​

​

Thành viên mới

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

File đính kèm

Thành viên mới

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên mới

Thời gian đếm ngược.

bebo021999

bebo021999