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
. Đú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 ạ.
