dư liệu của em nhiêu ạ. em chỉ vidu vài trường hợp thoi ạ
dư liệu em nhiêu dùng hàm excel sơ lâu em chỉ vidu vài trường hợp thôi ạ. nếu có lệnh VBA thì nó tự chay nhanh hơn. rất mong nhân được sự giúp đỡ của các bác ạ
Gặp mấy vụ "dư liệu" với "vidu" thì autofillter lấy sai hết mất thôi.
Advanced Filter dễ hơn.
Option Explicit
Sub nhanbansheet()
Dim lr&, i&, maxS, ws As Worksheet
Application.ScreenUpdating = False
For Each ws In Sheets
If ws.Name <> "kiem tra" Then ws.Delete
Next
With Sheets("kiem tra")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
Application.CopyObjectsWithCells = False
.Copy after:=Sheets(Sheets.Count)
Application.CopyObjectsWithCells = True
End With
With ActiveSheet
.Name = "temp"
With .Range("AY1:AY" & lr)
.Formula = "=COUNTIF($A$1:A1,""STT"")"
.Value = .Value
End With
maxS = .Cells(lr, "AY").Value
End With
For i = 1 To maxS
Sheets("Temp").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = "Ketqua " & i
With .Range("AZ1:AZ" & lr)
.Value = "=$AY$1:$AY$" & lr & "/($AY$1:$AY$" & lr & "=" & i & ")"
.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End With
.Columns("AY:AZ").Delete
End With
Next
Sheets("Temp").Delete
Sheets("kiem tra").Activate
Application.ScreenUpdating = True
End SubQuả là thiên tài. .
Tên sheet không nên dùng tiếng Việt có dấu
Sub ABC()
Dim arr(), sh As Worksheet, eRow&, eR&, i&, k&, fRow&
Const shName$ = "KetQua"
With Sheets("kiem tra")
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow < 2 Then MsgBox ("Khong co du lieu!"): Exit Sub
arr = .Range("A1:A" & eRow + 1).Value
arr(eRow + 1, 1) = "STT"
On Error Resume Next
Application.ScreenUpdating = False
For i = 1 To eRow
If arr(i, 1) = "STT" Then fRow = i
If arr(i + 1, 1) = "STT" Then
k = k + 1
Set sh = Sheets(shName & k)
If Err.Number > 0 Then
Err.Number = 0
Sheets.Add After:=Sheets(Sheets.Count)
Set sh = ActiveSheet
sh.Name = shName & k
End If
sh.UsedRange.Clear
.Range("A" & fRow & ":F" & i).Copy sh.Range("A1")
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Tach()
Dim i&, j&, Lr&, t&, k&, R&, C&
Dim Arr(), KQ(), TieuDe()
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("kiem tra")
Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Row
Arr = Sh.Range("A1:F" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
ReDim KQ(1 To R, 1 To C)
ReDim TieuDe(1 To 1, 1 To C)
For i = 1 To R
If Arr(i, 1) <> "STT" Then
t = t + 1
For j = 1 To C
KQ(t, j) = Arr(i, j)
Next j
Else
k = k + 1
For j = 1 To C
TieuDe(1, j) = Arr(i, j)
Next j
End If
If Arr(i, 1) = "STT" And k > 1 Then
Sheets.Add After:=Worksheets(Sheets.Count)
Set Ws = ActiveSheet
Ws.Range("A1").Resize(1, C) = TieuDe
Ws.Range("A2").Resize(t, C) = KQ
If WsExit(Ws.Cells(2, 2)) = False Then Ws.Name = Ws.Cells(2, 2)
t = 0
End If
Next i
MsgBox "Xong"
End SubThiên tài đây chứ đâu! Liệu việc như thần.
Sub tachdulieu()
Dim i, j, n As Integer
Dim lr As Long
Dim ws As Worksheet
'xoa worksheet ton tai truoc do
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "kiem tra" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
'tao worksheets theo stt
Worksheets("kiem tra").Activate
lr = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For i = 1 To lr
If Trim(UCase(Range("A" & i))) = "STT" Then
For j = i + 1 To lr
If Trim(UCase(Range("A" & j))) = "STT" Or j = lr Then
If j = lr Then
Range("A" & i, "F" & j).Copy
n = Application.Sheets.Count
Sheets.Add After:=Sheets(n)
Sheets(n + 1).Name = "KQ" & n
Sheets(n + 1).Range("A1").Select
ActiveCell.PasteSpecial
Worksheets("kiem tra").Activate
Else
Range("A" & i, "F" & j - 1).Copy
n = Application.Sheets.Count
Sheets.Add After:=Sheets(n)
Sheets(n + 1).Name = "KQ" & n
Sheets(n + 1).Range("A1").Select
ActiveCell.PasteSpecial
Worksheets("kiem tra").Activate
Exit For
End If
End If
Next j
End If
Next i
End Sub
