Trong khi chờ các giải pháp khác hãy thử tham khảo code sau:
Option Explicit
Sub TachSheet()
Dim i&, j&, Lr&
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("26.6.2023")
Lr = Sh.Cells(100000, 1).End(xlUp).Row
For i = 1 To Application.Max(Sh.Range("A8:A" & Lr))
Sh.Select
Sh.Copy After:=Sheets(Sheets.Count)
Selection.AutoFilter
ActiveSheet.Range("$A$8:$FT$211").AutoFilter Field:=1, Criteria1:="<>" & i, _
Operator:=xlAnd
Rows("9:" & Lr - 1).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
i = Format(i, "##")
ActiveSheet.Name = Sh.Name & "." & i
Next i
msgbox "Thành công"
End Subcode này chỉ sao chép, thiếu đoạn lọc và xóa dữ liệu theo điều kiện ở cột A : phân loại theo số thứ tự đó, và mỗi sheet nhỏ ( sau tách ) chỉ lấy 1 điều kiện là 1 số đó thôi
Bạn đã chạy code chưa? Có đúng là nó cho ra các sheets theo thứ tự 1, 2,3 và trong đó chỉ có các Lot 1,2,3 tương ứng.
Bạn cho hỏi thêm nếu mình cần thay đổi sheet name thì cần sửa đoạn này như nào nhỉ
Thì bạn cứ thay đổi dòng trong dấu "xxx...yyy" là được với điều kiện là có Sheets("xxx...YYY") và sheet ấy nằm trong workbook chứa code.
File của bạn có 2000 mã, vậy làm sao tách ra 2000 sheet đây? Bạn có từng nghĩ qua chưa?
Dạ không phải tách theo từng sheet là từng mã anh. Mà một sheet có thể nhiều mã. Nhưng với điều kiện là không để dữ liệu một mã mà chia ra ở 2 sheet á anh.
Bạn đọc kỹ lại những gì bạn viết xem có mâu thuẩn không.
Dạ chắc là câu từ em không rõ ràng. E xin trình bày lại là với sheet file 1 em có khoảng 80000 dòng gồm khoảng 2000 mã. Ví dụ em muốn tách ra thành 4 sheet. thì một sheet khoảng 20000 dòng đi ( có thể lên xuống) Nhưng trường hợp tách ra thì tách hết dữ liệu một mã nằm trên một sheet chứ không phải tách ra 2 sheet khác nhau. . Em có làm một ví dụ cho Mã 0013A4V-S40263P ở file đính kèm phần em bôi vàng cho mã đó. Em muốn dữ liệu đó chia nằm về một sheet. Không để trường hợp một mã sản phẩm mà nằm trên 2 sheet khác nhau. Em cảm ơn anh!
Giờ thì hiểu rồi. Chỉ cần tách ra 4 sheet, bao nhiều dòng cũng được, baonhiêu mã cũng được, chỉ cần vét hết thông tin của 1 mã về chung với nhau. Khó
Vì số lượng dòng còn nhiều lắm anh. Nên e kêu để đưa lên có các anh chị hỗ trợ thử được không.
. Em cảm ơn anh nhiều!
Cứ 1 sheet có 500 mã, cũng công bằng mà! Công bằng theo số mã,
Tình hình là số lượng còn rất nhiều, cả triệu dòng bác ạ. Đây 80000 mới là nhá hàng thôi.
Dữ liệu có mã giống nhau nằm kế bên nhau, chạy code
Sub XYZ()
Dim arr(), aCF(), res(), sRow&, N&, i&, r&, k&, t&, j&
Const d = 4 'So sheet DL ket qua
With Sheets("FILE 1")
arr = .Range("B2:E" & .Range("B" & Rows.Count).End(xlUp).Row + 1).Value
End With
sRow = UBound(arr) - 1
N = sRow / d
ReDim aCF(1 To d)
For i = 1 To sRow
k = k + 1
If arr(i, 1) <> arr(i + 1, 1) Then
If k > (r + 1) * N Then
r = r + 1
aCF(r) = t 'Tan so tich luy
End If
t = k
End If
Next i
aCF(d) = sRow
Application.ScreenUpdating = False
t = 1
For r = 1 To d
ReDim res(1 To aCF(r) - t + 1, 1 To 4)
k = 0
For i = t To aCF(r)
k = k + 1
For j = 1 To 4
res(k, j) = arr(i, j)
Next j
Next i
t = i
With Sheets("DL" & r)
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 1 Then .Range("A2:D" & i).Clear
.Range("A2").Resize(k, 4) = res
.Range("A2").Resize(k, 4).Borders.LineStyle = 1
End With
Next r
Application.ScreenUpdating = True
End SubSub Tach_Sheet()
Dim sArr(), i As Long, Res(), k As Long, j As Long, TieuDe As Range
With Sheets("File 1")
.Range("B1").CurrentRegion.Sort .Range("B1"), Header:=xlYes
sArr = .Range("B1", .Range("B" & Rows.Count).End(3).Offset(1)).Resize(, 4).Value
Set TieuDe = .Range("B1").Resize(, 5)
End With
ReDim Res(1 To UBound(sArr), 1 To 5)
For i = 2 To UBound(sArr) - 1
k = k + 1
If k < UBound(sArr) \ 4 Or sArr(i, 1) = sArr(i + 1, 1) Then
For j = 1 To 4
Res(k, j) = sArr(i, j)
Next
Res(k, 5) = k
Else
For j = 1 To 4
Res(k, j) = sArr(i, j)
Next
Res(k, 5) = k
Sheets.Add before:=Sheets(Sheets.Count)
With ActiveSheet
.Range("B2").Resize(k, UBound(Res, 2)) = Res
TieuDe.Copy .Range("B1")
End With
k = 0
ReDim Res(1 To UBound(sArr), 1 To 5)
End If
If i = UBound(sArr) - 1 Then
Sheets.Add before:=Sheets(Sheets.Count)
With ActiveSheet
.Range("B2").Resize(k, UBound(Res, 2)) = Res
TieuDe.Copy .Range("B1")
End With
End If
Next
End Sub
