Nhờ các cao thủ giúp đỡ công thức lọc, tách.
- Thread starter nguyenkar
- Ngày gửi
Phuocam
Thành viên mới
- Tham gia
- 16/5/13
- Bài viết
- 4,546
- Được thích
- 7,337
.
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
Thành viên gạo cội
- Tham gia
- 26/1/11
- Bài viết
- 5,837
- Được thích
- 8,567
- Donate (Momo)
- Giới tính
- Nam
- Nghề nghiệp
- GPE
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:
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
Ronaldinho7
Zl: 0933707265
- Tham gia
- 5/4/22
- Bài viết
- 186
- Được thích
- 204
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
Thành viên mới
- Tham gia
- 6/3/22
- Bài viết
- 26
- Được thích
- 6
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
Thành viên gạo cội
- Tham gia
- 24/7/18
- Bài viết
- 3,492
- Được thích
- 3,518
- Donate (Momo)
- Giới tính
- Nam
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.
- Tham gia
- 8/6/06
- Bài viết
- 14,326
- Được thích
- 22,370
- Nghề nghiệp
- Nuôi ba ba & trùn quế
(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 SubCò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 SubBạ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!
Lần chỉnh sửa cuối:
Nhattanktnn
Thành viên gắn bó
- Tham gia
- 11/11/16
- Bài viết
- 3,100
- Được thích
- 3,995
- Donate (Momo)
- Giới tính
- Nam
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))),"")
- Tham gia
- 4/11/07
- Bài viết
- 13,820
- Được thích
- 36,342
- Donate (Momo)
- Giới tính
- Nam
- Nghề nghiệp
- Consultant
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
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
Zl: 0933707265
- Tham gia
- 5/4/22
- Bài viết
- 186
- Được thích
- 204
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 Subnguyenkar
Thành viên mới
- Tham gia
- 6/3/22
- Bài viết
- 26
- Được thích
- 6
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é.
Lần chỉnh sửa cuối:
Ronaldinho7
Zl: 0933707265
- Tham gia
- 5/4/22
- Bài viết
- 186
- Được thích
- 204
Tôi nghĩ chắc bạn bị vướng hay nhầm lẫn chỗ nào đó thôi.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
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
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
Thành viên mới
- Tham gia
- 6/3/22
- Bài viết
- 26
- Được thích
- 6
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 SubMì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
Thành viên gạo cội
- Tham gia
- 26/1/11
- Bài viết
- 5,837
- Được thích
- 8,567
- Donate (Momo)
- Giới tính
- Nam
- Nghề nghiệp
- GPE
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
