Lọc nhiều lớp ra thành từng lớp (1 người xem)

  • Thread starter Thread starter 0167767
  • Ngày gửi Ngày gửi

Người dùng đang xem chủ đề này

0167767

Thành viên hoạt động
Tham gia
10/3/12
Bài viết
141
Được thích
10
Lọc nhiều lớp ra thành từng lớp. câu hỏi có trong file mong các bạn giúp đỡ, cảm ơn các bạn
 

File đính kèm

Lọc nhiều lớp ra thành từng lớp. câu hỏi có trong file mong các bạn giúp đỡ, cảm ơn các bạn
Bạn thực hiện như sau:
Bôi đen vùng D6:D1013--> Data-->Filter-->Advance Filter-->Tích Copy to another location--> Trong Copy to nháy chuột chọn ô F6--> Tích chọn Unique records only-->OK.
 
Mình muốn tự động, có công thức nào không bạn giúp mình nhé.
 
Bạn thử mình xem nhé
 
Xem đã đúng ý chưa nhé?
Nhớ Enable Macros trước khi mở File nhé! (Xem hướng dẫn tại chữ kí bên dưới bài viết của tôi)
 

File đính kèm

Của bạn đây!.................
Sao áp dụng vào file mình chưa được, bạn hướng dẫn mình thao tác cho mình nhé.
Mình thao tác như sau.
B1: Copy code này vào sheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Intersect(Target, [D7:D10000]) Is Nothing Then Call LOC
End Sub
B2: Copy code này vào module
Sub LOC() Range("D6:D" & Range("D65500").End(xlUp).Row).AdvancedFilter xlFilterCopy, _
Range("F6"), Unique:=True
End Sub
Sao nó báo lỗi ở code bước 1.
Cmr ơn bạn
 
Sao áp dụng vào file mình chưa được, bạn hướng dẫn mình thao tác cho mình nhé.
Mình thao tác như sau.
B1: Copy code này vào sheet

B2: Copy code này vào module
Sao nó báo lỗi ở code bước 1.
Cmr ơn bạn
Bạn xem File thật của bạn cấu trúc có giống File bạn gửi lên không?
Bạn Test File tôi gửi có đúng không?
 
Bạn xem File thật của bạn cấu trúc có giống File bạn gửi lên không?
Bạn Test File tôi gửi có đúng không?
File của bạn ok rồi. File mình dữ liệu lớp ở D7:D2006 Lọc sang F7. Ngoài chép code ra còn làm gì nữa không bạn, có vào advacedfilter gì gì nữa không?
 
Giúp mình thì còn gì bằng, quang trọng mình phải biết cách làm nữa chứ bạn
 
Lần chỉnh sửa cuối:

File đính kèm

Lần chỉnh sửa cuối:
Bạn Hải, bạn giúp mình lại với, cách làm cũng giống như bạn, nhưng tôi đã thêm cột vào nên không tách ra được hết, bạn giúp mình hé, chân thành cảm ơn bạn.
Dữ liệu bạn chuẩn bị kiểu vậy chắc 3 phút là xong . Bạn Quang Hải viết code xong text thử chắc mất vài tiếng . Bạn cẩu thả vậy thì chắc chờ thôi .
 

File đính kèm

Lần chỉnh sửa cuối:
To: 0167767
Bạn Copy code này về sẽ tách được. Code dựa theo dữ liệu của bài 25
Lưu ý là tên sheet TONGHOP và TONG HOP sẽ khác nhau, code sẽ phân biệt có khoảng cách và không khoảng cách.
Bạn cũng nên tự thay code vào và mò sửa nếu có nhu cầu học VBA. Mình cũng học theo cách này thôi
PHP:
Sub tachra()
Application.ScreenUpdating = False
Dim data(), ketqua(1 To 65536, 1 To 6), Lop()
Dim tieude As Range, k, i , j, ii
With Sheets("TONGHOP")
    Set tieude = .[A6:F6]
   data = .Range(.[A7], .[F65536].End(3)).Value
End With
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(data)
        If Not .exists(data(i, 5)) Then
            .Add data(i, 5), ""
        End If
   Next
   Lop = .keys
End With
For i = 0 To UBound(Lop)
    For ii = 1 To UBound(data)
        If data(ii, 5) = Lop(i) Then
            k = k + 1
            ketqua(k, 1) = k
            For j = 2 To 6
                ketqua(k, j) = data(ii, j)
            Next
        End If
    Next
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
       .Name = Lop(i)
       tieude.Copy .[A6:F6]
       .[A7].Resize(k, 6) = ketqua
       .[A:F].Columns.AutoFit
       .[A7].Resize(k, 6).Borders.Value = 1
    End With
    k = 0
 Next
Sheets("TONGHOP").Select
Application.ScreenUpdating = True
End Sub
 

Bài viết mới nhất

Back
Top Bottom