Sau khi sử dụng bộ lọc, lấy giá trị nạp vào mảng

tuhocvba

Administrator
Thành viên BQT
Đây là một sheet dữ liệu Excel đang sử dụng bộ lọc. Các bạn để ý bên trái bức ảnh, sẽ thấy số thứ tự dòng không liên tục.
Đó là vị dữ liệu đang được loc.
Bạn cần đăng nhập để thấy đính kèm

Nếu dùng thao tác bằng tay copy vùng dữ liệu này ra một sheet mới, ta được dữ liệu cần.
Tuy nhiên nếu gán vào mảng thì không ổn:
Mã:
rend = .Cells(.Rows.Count, 2).End(xlUp).Row
        If rend < 2 Then Exit Sub
        
        arr = .Range(.Cells(1, 1), .Cells(rend, 5)).Value
Khi đó dữ liệu nạp vào mảng bao gồm cả dòng không hiển thị ở trên (không thỏa mãn điều kiện lọc), như vậy thì lại không đúng ý đồ.
Vậy có bạn nào có cao kiến nào không? Đưa ra giải pháp cụ thể bằng code thì càng tốt nhé.
 

BKKBG

Yêu THVBA nhất
Có lẽ bác phải copy ra sheet khác, sau đó gán vào mảng sau.
Chứ cũng không biết cách nào hơn.
 
Dữ liệu đang có ở sheet 1:
Bạn cần đăng nhập để thấy hình ảnh


Sau khi sử dụng bộ lọc:
Bạn cần đăng nhập để thấy hình ảnh

Mã:
Sub test1()
  Dim rend As Long
If ActiveSheet.AutoFilterMode = False Then Exit Sub

  ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
  ThisWorkbook.Sheets(2).Cells(1, 1).PasteSpecial
End Sub
Kết quả ở sheet 2:
Bạn cần đăng nhập để thấy hình ảnh


Nếu sheet 1 không sử dụng filter thì lệnh trên vô tác dụng, không copy được gì.
Nguồn:
 
B

bvtvba

Guest
Code trên phải sửa điều kiện thoát là:
Mã:
If ActiveSheet.FilterMode = False Then
        MsgBox "Ko su dung loc gi"
        Exit Sub
    End If
AutoFilterMode là bật bộ lọc nhưng không có lọc gì thì vẫn là True và code trên cũng vô tác dụng. Nên trong trường hợp cần sử dụng FilterMode.
Nguồn:
 

tuhocvba

Administrator
Thành viên BQT
Chủ đề tưởng đơn giản mà lôi thôi nhỉ.
Đây là code của một bác Nhật, xuất ra mảng khá ngon.
Mã:
Sub Test()
    Dim w1 As Variant
 
If ActiveSheet.AutoFilterMode = False Then Exit Sub 'tuhocvba de xuat dong code nay

    With ActiveSheet.AutoFilter.Range
        w1 = GetFilterdArea(.Cells)
       
    End With


End Sub

Function GetFilterdArea(r As Range) As Variant

    Dim w As Variant
    Dim tmp As Variant
    Dim v As Variant
    Dim Dobj As New DataObject
    Dim x As Long
    Dim y As Long
    Dim i As Long
    Dim j As Long

    r.Copy

    With Dobj
        .GetFromClipboard       'クリップボードからDataObjectにデータを取得
        tmp = .GetText          'そのデータを取り込み
        tmp = Split(Left(tmp, Len(tmp) - 2), vbCrLf)    '末尾の改行を削除
        y = UBound(tmp)             '行数(-1)
        For i = 0 To UBound(tmp)
            w = Split(tmp(i), vbTab)
            If i = 0 Then
                x = UBound(w)       '列数(-1)
                ReDim v(1 To y + 1, 1 To x + 1)
            End If
            For j = 0 To UBound(w)
                v(i + 1, j + 1) = w(j)
            Next
        Next
    End With

    Application.CutCopyMode = False

    GetFilterdArea = v

End Function
Nhớ thiết định thư viện này nhé:
Bạn cần đăng nhập để thấy đính kèm

Kết quả:
Bạn cần đăng nhập để thấy đính kèm

Nhân lại nói về phong cách thảo luận của mấy web Nhật, là các bác ấy không sử dụng ảnh, do đây là tài nguyên liên quan tới tiền. Trong khi ở VN, bài viết các bạn toàn đi hỏi nhưng lúc nào cũng đòi hỏi phải cho quyền nọ quyền kia (upload ảnh, upload file).
Nguồn:
 
D

Deleted member 1392

Guest
Người Nhật họ đúng hay thật.
 

Euler

Administrator
Thành viên BQT
1. Để không phải khai báo thư viện thì:
(Thực tế là máy tính của mình không tìm thấy thư viện như ảnh mà ad đưa ra).
Mã:
CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Đoạn code này mình đã sử dụng và thành công.

Ngoài ra kết quả tìm kiếm còn cho thấy có nhiều cách khác, các bạn test thử:
Mã:
Set Clip = CreateObject("MSFORMS.DataObject")
Mình chạy thử đoạn code này thì không được.

Đoạn dưới đây thì giống với ở phương án đầu tiên, có thêm tí mắm muối.
Mã:
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText "Day la noi dung se duoc cat trong clipboard"
    .PutInClipboard
End With
Nguồn tham khảo:

2. Về code trên thì không phải không có điểm lưu ý.
Phải đảm bảo được dữ liệu trên bảng tính không chứa vbTab Chr(13) (vbCrLf :Ký tự xuống dòng) ở trong string.
Thuật toán của họ là, sau khi lọc, họ tiến hành copy dữ liệu sau khi lọc mà đang hiện trên bảng tính Excel.
Mã:
GetFilterdArea(.Cells)
r.Copy
Dữ liệu copy này được lưu trong cái gọi là Clipboard là một string s.
Mã:
arr(1,1)    arr(1,2)    arr(1,3)
arr(2,1)    arr(2,2)    arr(2,3)
arr(3,1)    arr(3,2)    arr(3,3)
s = arr(1,1) & vbtab & arr(1,2) & vbtab & arr(1,3) & chr(13) & arr(2,1) & vbtab & arr(2,2) & vbtab & arr(2,3)...
Như vậy để tách ra làm các dòng thì phải dùng split và điều kiện phân tách là sử dụng chr(13) ( = vbCrLf).
Sau khi tách ra làm các dòng, thì với mỗi dòng dữ liệu lại dùng vbtab để tách ra thành từng phần tử của mảng. (bước A)
Nếu arr(1,1) của tôi là một chuỗi ký tự có cấu trúc là "abc" & vbtab
Thì việc phân tách ở bước (A) không phải tạo ra 3 cột dữ liệu mà là 4 cột dữ liệu.

Hoặc nội dung arr(1,1) của tôi là "a" & vbtab & "b" & vbtab & "c". Khi đó việc phân tách ở bước A sẽ cho ra kết quả không đúng như chúng ta kỳ vọng.
 
T

thanhphong

Guest
Như vậy theo phân tích của anh Euler thì có thể dùng cho các trường hợp thông thường. Tức là nội dung các ô trong bảng tính không chứa các ký tự đặc biệt như dấu xuống dòng, hoặc dấu Tab.
Đối với các bạn làm kế toán thì điều này là OK. Dữ liệu của các bạn là chữ và số, rất đơn giản.

Còn đối với data của ad:
Bạn cần đăng nhập để thấy hình ảnh

Nhìn vào cột B có thể thấy mỗi ô trong cột này đều chứa một đoạn văn dài, có dấu xuống dòng và cũng khó có thể nói dữ liệu không chứa dấu Tab. Nên để xử lý triệt để vấn đề này, theo em là ad cứ tạo workbook mới cho sạch sẽ, rồi copy ra đó, sau đó gán vào mảng. Xong xuôi thì đóng file Excel mới tạo ra (đóng nhưng không lưu). Phương án này khó chịu ở chỗ mất thời gian tạo ra workbook mới (có thể tính bằng giây), nhưng đảm bảo luôn luôn đúng.
 
B

bvtvba

Guest
Chấp nhận trễ 1-2s tạo workbook mới thì code sẽ như thế này:
Mã:
Sub Test()
    Dim rend    As Long
    Dim wbnew   As String
    Dim arr
   
   
    If ActiveSheet.FilterMode = False Then Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Application.SheetsInNewWorkbook = 1
    Workbooks.Add
    wbnew = ActiveWorkbook.Name
   
    ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
   
    Workbooks(wbnew).Sheets(1).Activate
    With Workbooks(wbnew).Sheets(1)
        .Cells(1, 1).Select
        ActiveSheet.Paste
Application.CutCopyMode = False
        rend = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = .Range(.Cells(2, 1), .Cells(rend, 5)).Value
    End With
    Workbooks(wbnew).Close SaveChanges:=False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Sửa lần cuối bởi điều hành viên:
Top