Lọc dữ liệu từ 1 sheet ra nhiều sheet theo điều kiện........ (2 người xem)

[Ls1102]

Em phải tách các MÃ giống nhau ra 1 sheet riêng, lười copy quá vì nó nhiều, a nào có công thức giúp em với

 

[thivantan]

Giúp bạn một cách thân.

Option Explicit
Sub Trich()
Application.ScreenUpdating = False
  Dim sh As Worksheet
  For Each sh In Worksheets
   If sh.Name <> "Sheet1" Then
   sh.Range("A1:D1000").Clear
    With Range(Sheet1.[A2], Sheet1.[D65536].End(xlUp))
    .AutoFilter 1, sh.Name
    .Copy: sh.[A1].PasteSpecial
    .AutoFilter
    End With
  End If
  Next sh
Application.ScreenUpdating = True
End Sub

 

[Lê Duy Thương]

em phải tách các mã giống nhau ra 1 sheet riêng, lười copy quá vì nó nhiều, a nào có công thức giúp em với

thử dùng công thức này xem sao

 

[TrungChinhs]

Em phải tách các MÃ giống nhau ra 1 sheet riêng, lười copy quá vì nó nhiều, a nào có công thức giúp em với

Công thức thì tôi không biết. Nếu bạn dùng được VBA thì tham khảo code này để vận dụng. Nó sẽ tự thêm Sheet và đặt tên Sheet theo dữ liệu nguuồn (bạn chỉ còn mỗi một việc là nhấn nút chạy code và thưởng thức thành quả).

Sub TachSh()
On Error Resume Next
Application.ScreenUpdating = False
With Sheets("Sheet1")
    .[b2].Resize(1000).AdvancedFilter 1, Unique:=1
    For Each cls In Sheets("Sheet1").[b3].Resize(1000).SpecialCells(2).SpecialCells(12)
        Sheets.Add.Move After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = cls
        .[b2].Resize(1000).AutoFilter 1, cls
        .[b2].CurrentRegion.Copy Sheets(Sheets.Count).[b2]
        With Sheets(Sheets.Count).[b2].CurrentRegion
            .WrapText = False
            .Columns.AutoFit
        End With
    Next
    .AutoFilterMode = 0
 End With
End Sub

 

[khamha]

Giúp bạn một cách thân.

Option Explicit
Sub Trich()
Application.ScreenUpdating = False
  Dim sh As Worksheet
  For Each sh In Worksheets
   If sh.Name <> "Sheet1" Then
   sh.Range("A1:D1000").Clear
    With Range(Sheet1.[A2], Sheet1.[D65536].End(xlUp))
    .AutoFilter 1, sh.Name
    .Copy: sh.[A1].PasteSpecial
    .AutoFilter
    End With
  End If
  Next sh
Application.ScreenUpdating = True
End Sub

Bạn ơi,Có cách nào chỉ cho nó hoạt động với Sheet nằm trong điều kiện lọc,Còn các Sheet khác thì không bị ảnh hưởng gì?Cảm ơn bạn.
Ví dụ: chỉ có tác dụng cho những Sheet"DVS_1",Sheet"DVS_2",Sheet"DVS_3" và Sheet"DVS_4"

 

[datram]

Mình muốn tách thành các sheet theo số tài khoản, bạn nào giúp mình với đc ko ạ? bên mình chuẩn bị thanh tra thuế mà phần mềm ko đổ theo sheet đc. mình cám ơn rất nhiều!

 

[nguyenthuy13388]

Bạn ơi,Có cách nào chỉ cho nó hoạt động với Sheet nằm trong điều kiện lọc,Còn các Sheet khác thì không bị ảnh hưởng gì?Cảm ơn bạn.
Ví dụ: chỉ có tác dụng cho những Sheet"DVS_1",Sheet"DVS_2",Sheet"DVS_3" và Sheet"DVS_4"

Bạn thử chạy Sub sau:

Sub tachsheet()
Dim sArr As Variant, sh As Worksheet
Dim i As Long, Lr As Long, Lr1 As Long, ShN As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
With Sheet1
    Lr = .Range("A10000").End(xlUp).Row
    sArr = .Range("A3:D" & Lr).Value2
End With
For i = 1 To UBound(sArr)
    If InStr(ShN, sArr(i, 1)) = 0 Then
        ShN = ShN & sArr(i, 1)
        Sheets.Add After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("A1").Value = "Ma:"
            .Range("B1").Value = sArr(i, 1)
            .Range("A2:D2").Value = Sheet1.Range("A2:D2").Value
            '.Cells.Font.Name = ".VnTime"
            .Name = sArr(i, 1)
        End With
    End If
    For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
    With sh
        If .Name = sArr(i, 1) Then
            Lr1 = .Range("A10000").End(xlUp).Row + 1
            .Range("A" & Lr1) = sArr(i, 1)
            .Range("B" & Lr1) = sArr(i, 2)
            .Range("B" & Lr1).Font.Name = ".VnTime"
            .Range("C" & Lr1) = sArr(i, 3)
            .Range("D" & Lr1) = sArr(i, 4)
            .Range("D" & Lr1).Font.Name = ".VnTime"
        End If
    End With
    End If
    Next sh
Next i
Sheet1.Select
Application.ScreenUpdating = True
End Sub

 

[LamNA]

Mình muốn tách thành các sheet theo số tài khoản, bạn nào giúp mình với đc ko ạ? bên mình chuẩn bị thanh tra thuế mà phần mềm ko đổ theo sheet đc. mình cám ơn rất nhiều!

Xem đúng ý chưa nhé

 

[datram]

Xem đúng ý chưa nhé

Ôi đúng rồi, cám ơn anh nhiều lắm. Nếu đc anh chỉ giúp Trâm cách làm để Trâm làm cho năm 2018 luôn.

 

[LamNA]

Ôi đúng rồi, cám ơn anh nhiều lắm. Nếu đc anh chỉ giúp Trâm cách làm để Trâm làm cho năm 2018 luôn.

Gửi lại Trâm, nếu vấn đề gì khác thì lập topic mới cho riêng mình để mọi người hỗ trợ.

 

[datram]

Gửi lại Trâm, nếu vấn đề gì khác thì lập topic mới cho riêng mình để mọi người hỗ trợ.

Cám ơn anh nhiều! sáng nay ngồi mày mò theo file anh gửi Trâm làm đc rồi. Cám ơn anh lần nữa nha!

 

[thiendt2a]

Bác LamNa cho em hỏi .em copy lệnh của bác tháy báo lỗi biến cls.Vậy khi báo thế nào bác