Tách sheel tổng hợp thành nhiều sheel theo nhiều điều kiện bằng VBA

Liên hệ QC
C

chidung2009

Thành viên hoạt động
Tham gia
12/9/12
Bài viết
123
Được thích
8
Mình có 1 sheet tổng hợp giờ muốn tách thành nhiều sheel con theo hai điều kiện như sau:
- Tại ô G3 chọn tên huyện Đăk Hà ( hoặc bất kỳ) thì từ Sheet tổng hợp sẽ tách ra các sheel con chỉ liệt kê nhận viên đó thuộc huyện Đăk Hà , còn chức vụ thì Chánh án liệt kê vào Sheet ChanhAn, Thẩm phán vào Sheet ThamPhan, Nhân viên vào sheet NhanVien ....
- Nếu tại ô điều kiện G3 để trống thì liệt kê tất cả số nhân viên ở sheet TongHop vào các sheel con theo từng chức vụ tương ứng với từng sheet như trên
Mình xin cảm ơn
 

File đính kèm

  • Tach sheel.xlsb
    14.6 KB · Đọc: 17
Sắp xếp theo thời gian sắp xếp theo bầu chọn
chidung2009 đã viết:
Mình có 1 sheet tổng hợp giờ muốn tách thành nhiều sheel con theo hai điều kiện như sau:
- Tại ô G3 chọn tên huyện Đăk Hà ( hoặc bất kỳ) thì từ Sheet tổng hợp sẽ tách ra các sheel con chỉ liệt kê nhận viên đó thuộc huyện Đăk Hà , còn chức vụ thì Chánh án liệt kê vào Sheet ChanhAn, Thẩm phán vào Sheet ThamPhan, Nhân viên vào sheet NhanVien ....
- Nếu tại ô điều kiện G3 để trống thì liệt kê tất cả số nhân viên ở sheet TongHop vào các sheel con theo từng chức vụ tương ứng với từng sheet như trên
Mình xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Dùng thử File.
Copy dữ liệu vào sheet TongHop rồi nhấn nút để xem kết quả.
Tôi có công giúp nhớ xử tôi nhẹ tay nhé.
 

File đính kèm

  • Tach sheet.xlsb
    25.3 KB · Đọc: 19
Upvote 0
chidung2009 đã viết:
Mình có 1 sheet tổng hợp giờ muốn tách thành nhiều sheel con theo hai điều kiện như sau:
- Tại ô G3 chọn tên huyện Đăk Hà ( hoặc bất kỳ) thì từ Sheet tổng hợp sẽ tách ra các sheel con chỉ liệt kê nhận viên đó thuộc huyện Đăk Hà , còn chức vụ thì Chánh án liệt kê vào Sheet ChanhAn, Thẩm phán vào Sheet ThamPhan, Nhân viên vào sheet NhanVien ....
- Nếu tại ô điều kiện G3 để trống thì liệt kê tất cả số nhân viên ở sheet TongHop vào các sheel con theo từng chức vụ tương ứng với từng sheet như trên
Mình xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Tham khảo thêm 1 cách
Tạm thời danh sách cán bộ theo huyện ghi vào sheet tonghop cột G
Mã: 
Option Explicit
Dim dicTt As Object

Sub loc()
Dim nguon
Dim huyen
Dim ds, cv, tam
Dim rws, i, j, k, x, z
With Sheet1
    nguon = .Range("A4", "E" & .Range("D4").End(xlDown).Row)
    huyen = .Range("G3")
    rws = UBound(nguon)
End With

If dicTt Is Nothing Then
    Set dicTt = CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        z = Left(nguon(i, 4), 1)
        If dicTt.Exists(nguon(i, 3)) = False Then
            ReDim tam(1 To rws, 1 To 5)
            ReDim ds(1 To rws, 1 To 1)
            ds(1, 1) = nguon(i, 2)
            ReDim cv(1 To rws, 1 To 5)
            For j = 1 To 5
                cv(1, j) = nguon(i, j)
            Next j
            'ten; chanhan; thamphan; nhanvie; ketoan
            If z = "C" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(1, cv), Array(0, tam), Array(0, tam), Array(0, tam))
            If z = "T" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(1, cv), Array(0, tam), Array(0, tam))
            If z = "N" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(0, tam), Array(1, cv), Array(0, tam))
            If z = "K" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(0, tam), Array(0, tam), Array(1, cv))
        Else
            tam = dicTt(nguon(i, 3))
            ds = tam(0)(1)
            k = tam(0)(0)
            k = k + 1
            ds(k, 1) = nguon(i, 2)
            tam(0) = Array(k, ds)
           
            If z = "C" Then k = 1
            If z = "T" Then k = 2
            If z = "N" Then k = 3
            If z = "K" Then k = 4
            cv = tam(k)(1)
            x = tam(k)(0) + 1
            For j = 1 To 5
                cv(x, j) = nguon(i, j)
            Next j
            tam(k) = Array(x, cv)
            dicTt(nguon(i, 3)) = tam
        End If
    Next i
End If

For Each k In Worksheets
    If k.Name <> "TongHop" Then k.Range("A4").Resize(rws, 5).ClearContents
Next k
Sheet1.Range("G5", "G" & rws + 5).ClearContents

If huyen = "" Then
    For Each tam In dicTt.Items
        k = tam(1)(0)
        ds = tam(1)(1)
        If k > 0 Then Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(2)(0)
        ds = tam(2)(1)
        If k > 0 Then Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(3)(0)
        ds = tam(3)(1)
        If k > 0 Then Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(4)(0)
        ds = tam(4)(1)
        If k > 0 Then Sheet5.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    Next tam
Else
    tam = dicTt(huyen)
    Sheet1.Range("G5").Resize(tam(0)(0), 1) = tam(0)(1)
    k = tam(1)(0)
    ds = tam(1)(1)
    If k > 0 Then Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(2)(0)
    ds = tam(2)(1)
    If k > 0 Then Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(3)(0)
    ds = tam(3)(1)
    If k > 0 Then Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(4)(0)
    ds = tam(4)(1)
    If k > 0 Then Sheet5.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
End If
End Sub
 
Upvote 0
be09 đã viết:
Dùng thử File.
Copy dữ liệu vào sheet TongHop rồi nhấn nút để xem kết quả.
Tôi có công giúp nhớ xử tôi nhẹ tay nhé.
Nhấp chuột vào đây để mở rộng...
gần được như ý mình rồi. cảm ơn anh be09 nhiều nha
Bài đã được tự động gộp:

CHAOQUAY đã viết:
Tham khảo thêm 1 cách
Tạm thời danh sách cán bộ theo huyện ghi vào sheet tonghop cột G
Mã: 
Option Explicit
Dim dicTt As Object

Sub loc()
Dim nguon
Dim huyen
Dim ds, cv, tam
Dim rws, i, j, k, x, z
With Sheet1
    nguon = .Range("A4", "E" & .Range("D4").End(xlDown).Row)
    huyen = .Range("G3")
    rws = UBound(nguon)
End With

If dicTt Is Nothing Then
    Set dicTt = CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        z = Left(nguon(i, 4), 1)
        If dicTt.Exists(nguon(i, 3)) = False Then
            ReDim tam(1 To rws, 1 To 5)
            ReDim ds(1 To rws, 1 To 1)
            ds(1, 1) = nguon(i, 2)
            ReDim cv(1 To rws, 1 To 5)
            For j = 1 To 5
                cv(1, j) = nguon(i, j)
            Next j
            'ten; chanhan; thamphan; nhanvie; ketoan
            If z = "C" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(1, cv), Array(0, tam), Array(0, tam), Array(0, tam))
            If z = "T" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(1, cv), Array(0, tam), Array(0, tam))
            If z = "N" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(0, tam), Array(1, cv), Array(0, tam))
            If z = "K" Then dicTt(nguon(i, 3)) = Array(Array(1, ds), Array(0, tam), Array(0, tam), Array(0, tam), Array(1, cv))
        Else
            tam = dicTt(nguon(i, 3))
            ds = tam(0)(1)
            k = tam(0)(0)
            k = k + 1
            ds(k, 1) = nguon(i, 2)
            tam(0) = Array(k, ds)
         
            If z = "C" Then k = 1
            If z = "T" Then k = 2
            If z = "N" Then k = 3
            If z = "K" Then k = 4
            cv = tam(k)(1)
            x = tam(k)(0) + 1
            For j = 1 To 5
                cv(x, j) = nguon(i, j)
            Next j
            tam(k) = Array(x, cv)
            dicTt(nguon(i, 3)) = tam
        End If
    Next i
End If

For Each k In Worksheets
    If k.Name <> "TongHop" Then k.Range("A4").Resize(rws, 5).ClearContents
Next k
Sheet1.Range("G5", "G" & rws + 5).ClearContents

If huyen = "" Then
    For Each tam In dicTt.Items
        k = tam(1)(0)
        ds = tam(1)(1)
        If k > 0 Then Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(2)(0)
        ds = tam(2)(1)
        If k > 0 Then Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(3)(0)
        ds = tam(3)(1)
        If k > 0 Then Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
        k = tam(4)(0)
        ds = tam(4)(1)
        If k > 0 Then Sheet5.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    Next tam
Else
    tam = dicTt(huyen)
    Sheet1.Range("G5").Resize(tam(0)(0), 1) = tam(0)(1)
    k = tam(1)(0)
    ds = tam(1)(1)
    If k > 0 Then Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(2)(0)
    ds = tam(2)(1)
    If k > 0 Then Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(3)(0)
    ds = tam(3)(1)
    If k > 0 Then Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
    k = tam(4)(0)
    ds = tam(4)(1)
    If k > 0 Then Sheet5.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 5) = ds
End If
End Sub
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn nha, code này chạy rất đúng với ý của mình
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3
Trả lời
50
Đọc
599
LuuAnh980
LuuAnh980
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
21
Đọc
371
ongke0711
ongke0711
S
Slicer không chuyển qua trạng thái mờ.
Trả lời
2
Đọc
61
SteveNguyen1991
S
H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
2
Đọc
129
Haidang7979
H
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
1
Đọc
52
DeTong
D
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom