Hỏi về cách tách dữ liệu 1 sheet ra nhiều sheet với số dòng như nhau !

[ndu96081631]

Bác ndu96081631 đang online có thể xem và giúp em bài em gửi trên không ạ? Em thấy anh có viết một Sub cho việc tách sheet nhưng sheet số lượng là cố định và không có lọc. Bác có rảnh giúp em yêu cầu trong file Test chút!

Bài này dùng VBA thì quá dễ rồi
Mọi code dạng "đồ chơi" tôi đã viết sẵn từ lâu, giờ chỉ việc "ráp" vào là "mần"
Copy hết cái đống "đồ chơi" này vào 1 Module:

Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
  Dim aTmp, arr, dic, aKey
  Dim lR As Long, lC As Long, dTmpVal As Double
  Dim bChk As Boolean
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmp = SourceArray
  ColIndex = ColIndex + LBound(aTmp, 2) - 1
  bChk = (InStr("><=", Left(SearchText, 1)) > 0)
  For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
    If bChk And SearchText <> "" Then
      dTmpVal = CDbl(aTmp(lR, ColIndex))
      If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
    Else
      If Left(SearchText, 1) = "!" Then
        If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
      Else
        If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    aKey = dic.Keys
    ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
    For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
      Next
    Next
    If HasTitle Then
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
  Dim aSrc, aRes
  Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
  Dim SheetName As String
  Dim lR As Long, lCount As Long
  Set wksSrc = Worksheets("Sheet1")
  aSrc = wksSrc.Range("A1:C10000")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Application.ScreenUpdating = False
  For lR = 2 To UBound(aSrc, 1)
    SheetName = CStr(aSrc(lR, 3))
    If Len(SheetName) Then
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, lR
        If Not SheetExists(SheetName) Then
          lCount = lCount + 1
          With Worksheets.Add(After:=Worksheets(lCount))
            .Name = SheetName
            .Tab.Color = vbRed
          End With
        Else
          Worksheets(SheetName).Tab.Color = False
        End If
        Set wks = Worksheets(SheetName)
        aRes = Filter2DArray(aSrc, 3, SheetName, True)
        wks.UsedRange.ClearContents
        wks.Range("A1").Resize(UBound(aRes, 1), 3).Value = aRes
      End If
    End If
  Next
  wksSrc.Select
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

Xong, trở ra bảng tính, bấm Alt + F8, chọn Sub Main và bấm Run ---> Xem kết quả

 

[Hai Lúa Miền Tây]

Chép cdoe sau vào ThisWorkbook:

Private Sub Workbook_NewSheet(ByVal sh As Object)
  sh.Move After:=Sheets(Sheets.Count)
  If dv <> "" Then sh.Name = dv

End Sub

Chép code sau vào Module:

Public dv As String

Sub TaoList()
With Sheet1
   .Range("C1:C1470").AdvancedFilter 2, , .Range("IV1"), True
   .Range("IV2:IV" & .[IV65500].End(xlUp).Row).Name = "Lop"
End With
End Sub
Sub xoa()
Dim sh As Worksheet
Application.DisplayAlerts = False
    For Each sh In ThisWorkbook.Sheets
        If UCase(sh.Name) <> "SHEET1" Then
            sh.Delete
        End If
    Next
Application.DisplayAlerts = True
End Sub
Sub TachSheet()
Application.ScreenUpdating = False
On Error Resume Next
xoa
TaoList
    With Sheet1
        For i = 1 To Range("Lop").Count
            dv = UCase(Range("Lop").Cells(i, 1))
            Sheets.Add
            .Range("A1:C1500").AutoFilter Field:=3, Criteria1:=dv
            .[A1].CurrentRegion.Copy Sheets(dv).[A1]
        Next
        .ShowAllData
        .Activate
    End With
Application.ScreenUpdating = True

End Sub

Sau cùng là chạy code TachSheet

 

[minmin-2012]

Bác: Hai Lúa Miền Tây:
Nhờ bác xem giúp em file này. EM muốn tách theo cột STT.

 

[Hai Lúa Miền Tây]

Bác: Hai Lúa Miền Tây:
Nhờ bác xem giúp em file này. EM muốn tách theo cột STT.

Cũng tương tự bài 22 thôi bạn
Chép cdoe sau vào ThisWorkbook:

Private Sub Workbook_NewSheet(ByVal sh As Object)
  sh.Move After:=Sheets(Sheets.Count)
  If dv <> "" Then sh.Name = dv

End Sub

Chép code sau vào Module:

Public dv As String

Sub TaoList()
With Sheet1
   .Range("I1:I2062").AdvancedFilter 2, , .Range("IV1"), True
   .Range("IV2:IV" & .[IV65500].End(xlUp).Row).Name = "STT"
   
End With
End Sub
Sub xoa()
Dim sh As Worksheet
Application.DisplayAlerts = False
    For Each sh In ThisWorkbook.Sheets
        If UCase(sh.Name) <> "SHEET1" Then
            sh.Delete
        End If
    Next
Application.DisplayAlerts = True
End Sub
Sub TachSheet()
Application.ScreenUpdating = False
On Error Resume Next
xoa
TaoList
    With Sheet1
        For i = 1 To Range("STT").Count
            dv = UCase(Range("STT").Cells(i, 1))
            Sheets.Add
            .Range("A1:I2062").AutoFilter Field:=9, Criteria1:=dv
            .[A1].CurrentRegion.Copy Sheets(dv).[A1]
        Next
        .ShowAllData
        .Activate
    End With
Application.ScreenUpdating = True

End Sub

Sau cùng là chạy code TachSheet

 

[kingvn]

Bác Hai Lúa cho em hỏi một chút. Cái này có tách thành từng file riênd, đặt tên theo quy ước được ko ạ?