Lọc ra nhiều sheets căn cứ theo điều kiện 1 cột. (1 người xem)

overnight_9 · 7/9/12

Dears các anh chị.
hổ trợ giúp mình đoạn code lọc ra nhiều sheets
tôi đang bập bẹ dùng (Array & vòng lặp) để tách dữ liệu ra nhiều sheets mà code chưa đúng chạy loạn cào cào hết,

Mục đích là căn cứ cột I để tách dữ liệu 9 cột còn lại qua các sheets có đảo vị trí các cột. những cột che đi là thực tế có dữ liệu khác.

PHP:

Sub locsheet()
Dim Rng, Kq(), cell As Range, I As Long, J As Long, Ws As Worksheet, Tem
Rng = Sheets("CB_CS").Range(Sheets("CB_CS").[I24], Sheets("CB_CS").[I55000].End(xlUp)).Resize(, 16).Value
For Each Ws In Worksheets
    If Ws.Name <> "CB_CS" Then
            Tem = Ws.[F19].Value
            ReDim Kq(1 To 20000, 1 To 9)
            For I = 1 To UBound(Rng, 1)
                If Rng(I, 1) = Tem Then
                    J = J + 1
                        Kq(J, 1) = Rng(I, 3): Kq(J, 2) = Rng(I, 6): Kq(J, 3) = Rng(I, 7): Kq(J, 4) = Rng(I, 10): _
                    Kq(J, 5) = Rng(I, 11): Kq(J, 6) = Rng(I, 10): Kq(J, 7) = Rng(I, 12): Kq(J, 8) = Rng(I, 15): Kq(J, 9) = Rng(I, 13)
                End If
            Next I
            Ws.[D21].Resize(J, 9).Value = Kq
    End If
Next
End Sub

cám ơn nhiều.

ChanhTQ@ · 7/9/12

Mình c ó vài í kiến nhỏ xin góp với bạn như sau

(1) Giải fáp bạn đang xài là

Cho dữ liệu tại trang mà mình gọi là CSDL vô mảng đã khai báo Rng()

Duyệt lần lượt từng trang tính
Nếu gặp trang tính nào không fải là trang 'CSDL' thì:

+ Duyệt từ đầu chí cuối mảng Rng(), thỏa điều kiện thì chép vô mảng KQ
+ Sau khi duyệt xong thì chép mảng KQ lên trang tính đang duyệt

Theo như mình thì mình sẽ khai báo 8 mảng KQ1.. . KQ8; & kèm với nó là 8 tham biến dùng để tăng chỉ số của mảng

Vậy ta chỉ duyệt 1 lần mảng Rng() mà thôi; Hễ gặp của anh nào thì chép vô mảng KQ thứ i của anh đó.

Bạn rỗi thì thử theo cách mình xem sao

Những chuyện tiếp theo đây là nhỏ như lá cỏ:

(2) Các dòng lệnh canh lề nên thẳng cột; Hình như của bạn thụt đầu dòng vô tội vạ;
Khi chưa bằng trình độ CG thì đừng bắt chướt CG chuyện này!

(3) Bạn xem dòng lệnh này có dễ nhìn hơn không:

PHP:

With Sheets("CB_CS")
    Rng = .Range(.[I24], .[I55000].End(xlUp)).Resize(, 16).Value
End With

(4) Bạn không nên xài cú fáp

Mã:

                Kq(J, 1) = Rng(I, 3):   Kq(J, 2) = Rng(I, 6) : _
                Kq(J, 3) = Rng(I, 7):   Kq(J, 4) = Rng(I, 10)

Tuy không ai cấm; nhưng nên xài vào lúc mọi cái trong macro đã là OK;

Cú fáp đó là thi vị nếu kết quả macro là mỹ mãn; Bằng ngược lại sẽ chả có tác dụng gì!

Thân!

Ghi chú thêm: Các bạn khác đừng nên sửa code, mà vạch đường để bạn í tự sửa cái nha!

ndu96081631 · 7/9/12

overnight_9 đã viết:
Dears các anh chị.
hổ trợ giúp mình đoạn code lọc ra nhiều sheets
tôi đang bập bẹ dùng (Array & vòng lặp) để tách dữ liệu ra nhiều sheets mà code chưa đúng chạy loạn cào cào hết,

Mục đích là căn cứ cột I để tách dữ liệu 9 cột còn lại qua các sheets có đảo vị trí các cột. những cột che đi là thực tế có dữ liệu khác.

Bài này rất dễ nếu dùng Advanced Filter! Thí nghiệm nhé:
1> Các hàm hổ trợ

PHP:

Function SheetExists(ByVal wksName As String) As Boolean
  On Error Resume Next
  SheetExists = Not ThisWorkbook.Sheets(wksName) Is Nothing
End Function

PHP:

Function GetUnique(ParamArray sArray())
  Dim SubArr, Item
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      For Each Item In SubArr
        If CStr(Item) <> "" Then
          If Not .Exists(CStr(Item)) Then .Add CStr(Item), ""
        End If
      Next
    Next
    GetUnique = IIf(.Count = 0, "", .Keys)
  End With
End Function

2> Code chính:

PHP:

Sub Main()
  Dim Title, wksName, CritArr
  Dim wks As Worksheet
  Dim SrcRng As Range, CritRng As Range
  On Error Resume Next
  Title = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
  Set SrcRng = Sheet16.Range("I22:X10000")
  Set CritRng = SrcRng.Offset(2).Resize(, 1)
  CritArr = GetUnique(CritRng)
  If IsArray(CritArr) Then
    For Each wksName In CritArr
      If SheetExists(CStr(wksName)) Then
        Set wks = Worksheets(CStr(wksName))
        wks.Range("D21:L20000").Clear
        wks.Range("D21:L21").Value = Title
        wks.Range("IV1") = "DK"
        wks.Range("IV2").Value = wksName
        SrcRng.AdvancedFilter 2, wks.Range("IV1:IV2"), wks.Range("D21:L21")
        wks.Range("IV1:IV2").Clear
      End If
    Next
  End If
End Sub

Chỉ cần chạy code chính là xong!

Quang_Hải · 7/9/12

overnight_9 đã viết:
Dears các anh chị.
hổ trợ giúp mình đoạn code lọc ra nhiều sheets
tôi đang bập bẹ dùng (Array & vòng lặp) để tách dữ liệu ra nhiều sheets mà code chưa đúng chạy loạn cào cào hết,

Mục đích là căn cứ cột I để tách dữ liệu 9 cột còn lại qua các sheets có đảo vị trí các cột. những cột che đi là thực tế có dữ liệu khác.

cám ơn nhiều.

Có thể tham khảo cách cơ bản của mình

overnight_9 · 7/9/12

dear Thay NDU.
Thầy giải thích giúp em chổ này tí

HTML:

wks.Range("IV1") = "DK"
        wks.Range("IV2").Value = wksName

địa chỉ thực trên bảng tính là chổ nào?

em cám ơn

Ba Tê · 7/9/12

quanghai1969 đã viết:
Có thể tham khảo cách cơ bản của mình

- Trường hợp này tôi cũng khoái dùng cách của quanghai, vì mỗi lần chỉ xem có 1 sheet "mắc" gì phải ghi ra tất cả các sheet.
- Vì khi xem chỉ 1 sheet nên dữ liệu các sheet khác để đầy trong đó cũng chẳng ích gì, chỉ làm tăng dung lượng File nếu nó có nhiều sheet, mỗi sheet có nhiều dòng - Nên chăng thêm "thằng" Deactivate xoá nó luôn khi không muốn xem nó nữa? (Đàng nào thi mỗi lần mở sheet thì cũng chạy code lấy dữ liệu mà!)
- Dòng này : ActiveSheet.[d21].Resize(k, 9) = kq dễ bị lỗi nếu k=0, nên bẫy lỗi cho nó. (Dzụ này tôi bị Ndu "bắt giò" hoài, Ẹc...)

Quang_Hải · 7/9/12

Ba Tê đã viết:
- Trường hợp này tôi cũng khoái dùng cách của quanghai, vì mỗi lần chỉ xem có 1 sheet "mắc" gì phải ghi ra tất cả các sheet.
- Vì khi xem chỉ 1 sheet nên dữ liệu các sheet khác để đầy trong đó cũng chẳng ích gì, chỉ làm tăng dung lượng File nếu nó có nhiều sheet, mỗi sheet có nhiều dòng - Nên chăng thêm "thằng" Deactivate xoá nó luôn khi không muốn xem nó nữa? (Đàng nào thi mỗi lần mở sheet thì cũng chạy code lấy dữ liệu mà!)
- Dòng này : ActiveSheet.[d21].Resize(k, 9) = kq dễ bị lỗi nếu k=0, nên bẫy lỗi cho nó. (Dzụ này tôi bị Ndu "bắt giò" hoài, Ẹc...)

Anh nói rất chí lý, nên thêm cái Deactive để clear dữ liệu cho nhẹ file

Cái vụ nếu k = 0 thì càng đúng, cái này em hay quên, lúc nhớ thì cũng thêm cái If nữa trước khi gán xuống sheet

overnight_9 · 7/9/12

dears bác ChanhTQ
em còn rất mênh mang chổ này

Theo như mình thì mình sẽ khai báo 8 mảng KQ1.. . KQ8; & kèm với nó là 8 tham biến dùng để tăng chỉ số của mảng

Vậy ta chỉ duyệt 1 lần mảng Rng() mà thôi; Hễ gặp của anh nào thì chép vô mảng KQ thứ i của anh đó.

bác gợi ý cụ thể giúp em bài này.

(4) Bạn không nên xài cú fáp

Code:

Kq(J, 1) = Rng(I, 3): Kq(J, 2) = Rng(I, 6) : _ Kq(J, 3) = Rng(I, 7): Kq(J, 4) = Rng(I, 10)
Tuy không ai cấm; nhưng nên xài vào lúc mọi cái trong macro đã là OK;

Cú fáp đó là thi vị nếu kết quả macro là mỹ mãn; Bằng ngược lại sẽ chả có tác dụng gì!

Em chỉ ngồi "ngâm " buổi tối nên vượt qua cửa cơ bản còn nhọc lắm, bác giúp em ít cơ bản, em cám ơn nhiều.

ndu96081631 · 7/9/12

overnight_9 đã viết:
dear Thay NDU.
Thầy giải thích giúp em chổ này tí

HTML:

wks.Range("IV1") = "DK" wks.Range("IV2").Value = wksName

em cám ơn

wks là từng sheet (từ 1 đến 9) khi ta dùng vòng lập duyệt qua
Tại wks, ta ghi chữ "DK" vào cell IV1 và điều kiện lọc tại cell IV2 (điều kiện lọc này chính là tên sheet đấy)
Giờ thì vùng IV1:IV2 (tại wks) sẽ trở thành vùng điều kiện lọc cho Advanced Filter ---> Thế thôi

overnight_9 đã viết:
địa chỉ thực trên bảng tính là chổ nào?
em cám ơn

Sau khi lọc xong tại sheet nào thì tôi xoá luôn IV1:IV2 nên dù bạn có tìm cũng không thấy đâu (do dòng code wks.Range("IV1:IV2").Clear đấy)

overnight_9 · 7/9/12

dears các anh,
giúp em nó sai chổ nào? mà đến

Mã:

kq(K, 4) = DL(i, 11)

là báo "subscript out of range"

em vừa sửa lại theo gọi ý các anh.

PHP:

Sub locsheet()
Dim DL, kq(), i As Long, K As Long, Ws As Worksheet, Tem
With Sheets("CB_CS")
    DL = .Range(.[P24], .[P55000].End(xlUp)).Offset(, -7).Resize(, 9).value
End With
For Each Ws In Worksheets
    If Ws.Name <> "CB_CS" Then
    Tem = Ws.[F19].Value
    ReDim kq(1 To UBound(DL, 1), 1 To 9)
        For i = 1 To UBound(DL, 1)
        If DL(i, 1) = Tem Then
        K = K + 1    
          kq(K, 1) = DL(i, 4)
            kq(K, 2) = DL(i, 7)
              kq(K, 3) = DL(i, 8)
                kq(K, 4) = DL(i, 11)
                 kq(K, 5) = DL(i, 12)
                   kq(K, 6) = DL(i, 10)
                     kq(K, 7) = DL(i, 13)
                       kq(K, 8) = DL(i, 16)
                         kq(K, 9) = DL(i, 14)
            End If
        Next i
        Ws.[D21].Resize(K, 9).Value = kq
        Ws [D21], [D20000].End(xlUp).Offset(, -2) = K
    End If
Next
End Sub

em cảm ơn

Quang_Hải · 7/9/12

overnight_9 đã viết:

dears các anh,
giúp em nó sai chổ nào? mà đến

Mã:

kq(K, 4) = DL(i, 11)

là báo "subscript out of range"

em vừa sửa lại theo gọi ý các anh.

PHP:

Sub locsheet()
Dim DL, kq(), i As Long, K As Long, Ws As Worksheet, Tem
With Sheets("CB_CS")
    DL = .Range(.[P24], .[P55000].End(xlUp)).Offset(, -7).Resize(, 8)
End With
For Each Ws In Worksheets
    If Ws.Name <> "CB_CS" Then
    Tem = Ws.[F19].Value
    ReDim kq(1 To UBound(DL, 1), 1 To 9)
        For i = 1 To UBound(DL, 1)
        If DL(i, 1) = Tem Then
        K = K + 1:
        kq(K, 1) = K
          kq(K, 1) = DL(i, 4)
            kq(K, 2) = DL(i, 7)
              kq(K, 3) = DL(i, 8)
                kq(K, 4) = DL(i, 11)
                 kq(K, 5) = DL(i, 12)
                   kq(K, 6) = DL(i, 10)
                     kq(K, 7) = DL(i, 13)
                       kq(K, 8) = DL(i, 16)
                         kq(K, 9) = DL(i, 14)
            End If
        Next i
        Ws.[D21].Resize(K, 9).Value = kq
    End If
Next
End Sub

em cảm ơn

Không cần test code cũng thấy lỗi rồi, bạn Resize có 8 cột cho mảng DL vậy mà bạn gọi hơn 8 là nó mắng mình liền

ndu96081631 · 7/9/12

quanghai1969 đã viết:
Không cần test code cũng thấy lỗi rồi, bạn Resize có 8 cột cho mảng DL vậy mà bạn gọi hơn 8 là nó mắng mình liền

- Cái này thì cứ Resize "bự bự" chút là được rồi (chính xác là Resize(, 16)

Mã:

With Sheets("CB_CS")
    DL = .Range(.[P24], .[P55000].End(xlUp)).Offset(, -7).Resize(, [COLOR=#ff0000][B]16[/B][/COLOR])
End With

- Ngoài ra, giá trị K nằm trong 2 vòng lập nên cứ qua vòng lập bên ngoài ta phải cho nó = 0

Mã:

For Each Ws In Worksheets
    If Ws.Name <> "CB_CS" Then
      K = 0
     ....

- Nên clear dữ liệu tại các sheet con trước khi gán, nếu không thì khi dữ liệu tại sheet CB_CS thay đổi, ta chạy code lần 2 có thể bị sai kết quả
Sửa tạm thế này:

PHP:

Sub locsheet()
  Dim DL, kq(), stt(), i As Long, K As Long, Ws As Worksheet, Tem
  DL = Sheets("CB_CS").Range("I24:X10000")
  For Each Ws In Worksheets
    If Ws.Name <> "CB_CS" Then
      K = 0
      Tem = Ws.[F19].Value
      ReDim kq(1 To UBound(DL, 1), 1 To 9)
      ReDim stt(1 To UBound(DL, 1), 1 To 1)
      For i = 1 To UBound(DL, 1)
        If DL(i, 1) = Tem Then
          K = K + 1
          stt(K, 1) = K
          kq(K, 1) = DL(i, 4)
          kq(K, 2) = DL(i, 7)
          kq(K, 3) = DL(i, 8)
          kq(K, 4) = DL(i, 11)
          kq(K, 5) = DL(i, 12)
          kq(K, 6) = DL(i, 10)
          kq(K, 7) = DL(i, 13)
          kq(K, 8) = DL(i, 16)
          kq(K, 9) = DL(i, 14)
        End If
      Next i
      If K Then
        Ws.Range("D21").Resize(10000, 9).ClearContents
        Ws.Range("B21").Resize(10000).ClearContents
        Ws.Range("B21").Resize(K).Value = stt
        Ws.Range("D21").Resize(K, 9).Value = kq
      End If
    End If
  Next
End Sub

overnight_9 · 7/9/12

ndu96081631 đã viết:
- Cái này thì cứ Resize "bự bự" chút là được rồi (chính xác là Resize(, 16)

Mã:

With Sheets("CB_CS") DL = .Range(.[P24], .[P55000].End(xlUp)).Offset(, -7).Resize(, [COLOR=#ff0000][B]16[/B][/COLOR]) End With

- Ngoài ra, giá trị K nằm trong 2 vòng lập nên cứ qua vòng lập bên ngoài ta phải cho nó = 0

Mã:

For Each Ws In Worksheets If Ws.Name <> "CB_CS" Then K = 0 ....

- Nên clear dữ liệu tại các sheet con trước khi gán, nếu không thì khi dữ liệu tại sheet CB_CS thay đổi, ta chạy code lần 2 có thể bị sai kết quả

Cảm ơn thầy NDU, bây giời thì cái đầu em mới nhẹ hơn cái đít EC....EC....., em thông kiểu dạng này rồi .... giờ mới tư duy thêm cái khác được.

overnight_9 · 7/9/12

quanghai1969 đã viết:
Không cần test code cũng thấy lỗi rồi, bạn Resize có 8 cột cho mảng DL vậy mà bạn gọi hơn 8 là nó mắng mình liền

dears anh Hai.
Hôm nay anh nói mới biết đó, cái vụ Resize này mấy hôm nay em không để ý, em cứ nghĩ kiểu "gà" là nó tự cộng thêm thằng offset nữa là đủ. em học kiểu căng đầu chứ hok phải căn bản EC...EC.... EC.....

overnight_9 · 8/9/12

ndu96081631 đã viết:

Bài này rất dễ nếu dùng Advanced Filter! Thí nghiệm nhé:
1> Các hàm hổ trợ

PHP:

Function SheetExists(ByVal wksName As String) As Boolean
  On Error Resume Next
  SheetExists = Not ThisWorkbook.Sheets(wksName) Is Nothing
End Function

PHP:

Function GetUnique(ParamArray sArray())
  Dim SubArr, Item
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      For Each Item In SubArr
        If CStr(Item) <> "" Then
          If Not .Exists(CStr(Item)) Then .Add CStr(Item), ""
        End If
      Next
    Next
    GetUnique = IIf(.Count = 0, "", .Keys)
  End With
End Function

dear thầy NDU
2 cái function này rất hay và bổ ích, 1 cái check sheet trong workbook, 1 cái check item trong sheet, em dù em đang mênh mang với nó nhưng em không dám hỏi nữa vì sợ tẩu hỏa nhập ma. những bài sau liên quan đến nó em sẽ họi lại. cảm ơn thầy nhé

Lọc ra nhiều sheets căn cứ theo điều kiện 1 cột. (1 người xem)

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

overnight_9

strive for mastery

File đính kèm

ChanhTQ@

0901452không62

ndu96081631

Huyền thoại GPE

File đính kèm

Quang_Hải

Thành viên gạo cội

File đính kèm

overnight_9

strive for mastery

Ba Tê

Cạo Rồi Khỏi Gội

Quang_Hải

Thành viên gạo cội

overnight_9

strive for mastery

ndu96081631

Huyền thoại GPE

overnight_9

strive for mastery

Quang_Hải

Thành viên gạo cội

ndu96081631

Huyền thoại GPE

overnight_9

strive for mastery

overnight_9

strive for mastery

overnight_9

strive for mastery

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

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

Đếm ngược thời gian