Trích xuất dữ liệu có điều kiện

Liên hệ QC
K

kedote111222333

Thành viên mới
Tham gia
14/9/17
Bài viết
19
Được thích
0
Giới tính
Nam
Em chào các a chị. Có vấn đề này mong các a chị giúp đỡ em ạ
Em có 1 file có 2 sheet
Sheet “Tổng” chứa dữ liệu gốc
Sheet “ Chi Tiết” chứa dữ liệu em muốn lọc từ sheet “Tổng” sang
Em muốn: Khi chọn giá trị ở ô “B4” thì các trường Mã nhà cung cấp sẽ tự update list dữ liệu tương ứng.
Nếu lọc bằng tay bên sheet “Tổng” rồi copy sang sheet “ Chi Tiết” thì rất mất thời gian. Hơn nữa dữ liệu em cần lọc khá nhiều trường Mã nhà cung cấp nên không thể làm bằng cách record Macro được.
Kiến thức của em về VBA còn rất hạn chế, rất mong được sự giúp đỡ của các a chị
Em cám ơn ạ !
 

File đính kèm

  • TEST DATA.xlsm
    12.3 KB · Đọc: 25
Các a chị có thể giúp đỡ em với ạ
 
Code cho sheet Chi tiết nhé.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aData As Variant, aResult As Variant
If Target.Address <> "$B$4" Then Exit Sub
aData = Sheet2.Range("B2").CurrentRegion.Value
aResult = GetData(aData, 2, Target.Value)
If IsEmpty(aResult) Then
    Range("C3").Resize(100, 20).ClearContents
Else
    Range("C3").Resize(UBound(aResult, 1), UBound(aResult, 2)).Value = aResult
End If
End Sub
Private Function GetData(ByRef aData As Variant, ByVal MainCol As Long, sHeaderName As String) As Variant
Dim aResult() As Variant, aIndex() As Long, oDic As Object, DataCol As Long, iGroup As Long, NumOfGroup As Long
ReDim aResult(1 To 100, 1 To 1)
ReDim aIndex(1 To 1)
For i = 1 To UBound(aData, 2)
    If aData(1, i) = sHeaderName Then
        DataCol = i
        Exit For
    End If
Next
If DataCol > 0 Then
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(aData, 1)
        If oDic.Exists(aData(i, MainCol)) Then
            iGroup = oDic.Item(aData(i, MainCol))
            aIndex(iGroup) = aIndex(iGroup) + 1
            aResult(aIndex(iGroup), iGroup) = aData(i, DataCol)
        Else
            NumOfGroup = NumOfGroup + 1
            ReDim Preserve aResult(1 To 100, 1 To NumOfGroup)
            ReDim Preserve aIndex(1 To NumOfGroup)
            oDic.Add aData(i, MainCol), NumOfGroup
            aResult(1, NumOfGroup) = aData(i, MainCol)
            aResult(2, NumOfGroup) = aData(i, DataCol)
            aIndex(NumOfGroup) = 2
        End If
    Next
    GetData = aResult
End If
End Function
 
huuthang_bd đã viết:
Code cho sheet Chi tiết nhé.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aData As Variant, aResult As Variant
If Target.Address <> "$B$4" Then Exit Sub
aData = Sheet2.Range("B2").CurrentRegion.Value
aResult = GetData(aData, 2, Target.Value)
If IsEmpty(aResult) Then
    Range("C3").Resize(100, 20).ClearContents
Else
    Range("C3").Resize(UBound(aResult, 1), UBound(aResult, 2)).Value = aResult
End If
End Sub
Private Function GetData(ByRef aData As Variant, ByVal MainCol As Long, sHeaderName As String) As Variant
Dim aResult() As Variant, aIndex() As Long, oDic As Object, DataCol As Long, iGroup As Long, NumOfGroup As Long
ReDim aResult(1 To 100, 1 To 1)
ReDim aIndex(1 To 1)
For i = 1 To UBound(aData, 2)
    If aData(1, i) = sHeaderName Then
        DataCol = i
        Exit For
    End If
Next
If DataCol > 0 Then
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(aData, 1)
        If oDic.Exists(aData(i, MainCol)) Then
            iGroup = oDic.Item(aData(i, MainCol))
            aIndex(iGroup) = aIndex(iGroup) + 1
            aResult(aIndex(iGroup), iGroup) = aData(i, DataCol)
        Else
            NumOfGroup = NumOfGroup + 1
            ReDim Preserve aResult(1 To 100, 1 To NumOfGroup)
            ReDim Preserve aIndex(1 To NumOfGroup)
            oDic.Add aData(i, MainCol), NumOfGroup
            aResult(1, NumOfGroup) = aData(i, MainCol)
            aResult(2, NumOfGroup) = aData(i, DataCol)
            aIndex(NumOfGroup) = 2
        End If
    Next
    GetData = aResult
End If
End Function
Nhấp chuột vào đây để mở rộng...
Cám ơn bác nhiều. Để em test luôn xem sao ạ
Bài đã được tự động gộp:

huuthang_bd đã viết:
Code cho sheet Chi tiết nhé.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aData As Variant, aResult As Variant
If Target.Address <> "$B$4" Then Exit Sub
aData = Sheet2.Range("B2").CurrentRegion.Value
aResult = GetData(aData, 2, Target.Value)
If IsEmpty(aResult) Then
    Range("C3").Resize(100, 20).ClearContents
Else
    Range("C3").Resize(UBound(aResult, 1), UBound(aResult, 2)).Value = aResult
End If
End Sub
Private Function GetData(ByRef aData As Variant, ByVal MainCol As Long, sHeaderName As String) As Variant
Dim aResult() As Variant, aIndex() As Long, oDic As Object, DataCol As Long, iGroup As Long, NumOfGroup As Long
ReDim aResult(1 To 100, 1 To 1)
ReDim aIndex(1 To 1)
For i = 1 To UBound(aData, 2)
    If aData(1, i) = sHeaderName Then
        DataCol = i
        Exit For
    End If
Next
If DataCol > 0 Then
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(aData, 1)
        If oDic.Exists(aData(i, MainCol)) Then
            iGroup = oDic.Item(aData(i, MainCol))
            aIndex(iGroup) = aIndex(iGroup) + 1
            aResult(aIndex(iGroup), iGroup) = aData(i, DataCol)
        Else
            NumOfGroup = NumOfGroup + 1
            ReDim Preserve aResult(1 To 100, 1 To NumOfGroup)
            ReDim Preserve aIndex(1 To NumOfGroup)
            oDic.Add aData(i, MainCol), NumOfGroup
            aResult(1, NumOfGroup) = aData(i, MainCol)
            aResult(2, NumOfGroup) = aData(i, DataCol)
            aIndex(NumOfGroup) = 2
        End If
    Next
    GetData = aResult
End If
End Function
Nhấp chuột vào đây để mở rộng...
Bác có thể sửa luôn trong file giúp em được không ạ. Em có add đoạn code trên vào sheet " Chi Tiết" nhưng chạy thì mất hết dữ liệu1568872123933.png
 
Lần chỉnh sửa cuối:
Bạn đưa file mà bạn đã copy code vào tôi xem.
 
File ở bài #9 không phải file ở bài #1. Bạn cứ thử tải đúng file ở bài #1 về copy code vào xem có chạy đúng không.
Tôi không hiểu sao nhiều bạn mang file này đi hỏi nhưng lại sử dụng cho file kia rồi cứ bảo là không được!
 
huuthang_bd đã viết:
File ở bài #9 không phải file ở bài #1. Bạn cứ thử tải đúng file ở bài #1 về copy code vào xem có chạy đúng không.
Tôi không hiểu sao nhiều bạn mang file này đi hỏi nhưng lại sử dụng cho file kia rồi cứ bảo là không được!
Nhấp chuột vào đây để mở rộng...
Dạ vâng là do e mắc lỗi đã sửa sheet name không đúng. xin lỗi bác nha. cám ơn bác rất nhiều ạ.
 
TgiaiDungLe đã viết:
Hiện mình cũng đang gặp vấn đề tương tự như bác chủ thớt, đã tạo bài viết nhưng vẫn đang "bí" hy vọng được cao nhân giúp đỡ ạ. Link : https://www.giaiphapexcel.com/diendan/threads/nhờ-giúp-đỡ-code-vba-xử-lý-trích-xuất-dữ-liệu.144972/#post-936734
Nhấp chuột vào đây để mở rộng...
huuthang_bd đã viết:
Code cho sheet Chi tiết nhé.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aData As Variant, aResult As Variant
If Target.Address <> "$B$4" Then Exit Sub
aData = Sheet2.Range("B2").CurrentRegion.Value
aResult = GetData(aData, 2, Target.Value)
If IsEmpty(aResult) Then
    Range("C3").Resize(100, 20).ClearContents
Else
    Range("C3").Resize(UBound(aResult, 1), UBound(aResult, 2)).Value = aResult
End If
End Sub
Private Function GetData(ByRef aData As Variant, ByVal MainCol As Long, sHeaderName As String) As Variant
Dim aResult() As Variant, aIndex() As Long, oDic As Object, DataCol As Long, iGroup As Long, NumOfGroup As Long
ReDim aResult(1 To 100, 1 To 1)
ReDim aIndex(1 To 1)
For i = 1 To UBound(aData, 2)
    If aData(1, i) = sHeaderName Then
        DataCol = i
        Exit For
    End If
Next
If DataCol > 0 Then
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(aData, 1)
        If oDic.Exists(aData(i, MainCol)) Then
            iGroup = oDic.Item(aData(i, MainCol))
            aIndex(iGroup) = aIndex(iGroup) + 1
            aResult(aIndex(iGroup), iGroup) = aData(i, DataCol)
        Else
            NumOfGroup = NumOfGroup + 1
            ReDim Preserve aResult(1 To 100, 1 To NumOfGroup)
            ReDim Preserve aIndex(1 To NumOfGroup)
            oDic.Add aData(i, MainCol), NumOfGroup
            aResult(1, NumOfGroup) = aData(i, MainCol)
            aResult(2, NumOfGroup) = aData(i, DataCol)
            aIndex(NumOfGroup) = 2
        End If
    Next
    GetData = aResult
End If
End Function
Nhấp chuột vào đây để mở rộng...
Bạn thử làm theo cách của bác ấy xem sao
Vấn đề của tôi đã được giải quyết rồi đó.
 
nghiaphuc đã viết:
"
Nhấp chuột vào đây để mở rộng...
ptm0412 đã viết:
tính
Nhấp chuột vào đây để mở rộng...
kedote111222333 đã viết:
Bạn thử làm theo cách của bác ấy xem sao
Vấn đề của tôi đã được giải quyết rồi đó.
Nhấp chuột vào đây để mở rộng...
Vấn đề mình đang gặp cũng gần tương tự thôi ạ, ví dụ mình nhập tại ô A1 giá trị là Tháng 1 thì mình muốn khu vực A12:B25 bị ẩn đi
mình nhập ô A2 giá trị Tháng 2 thì khu vực A23:B24 bị ẩn đi
:( đã test code rất nhiều nhưng vẫn chưa chạy dc nên rất mong được chỉ giáo ạ
Các bác có thể qua xem giúp mình tại bài viết này ạ : https://www.giaiphapexcel.com/diendan/threads/nhờ-giúp-đỡ-code-vba-xử-lý-trích-xuất-dữ-liệu.144972/#post-936734
Mình có tham khảo qua đoạn code :
Code ẩn, tại 1 bài viết khác trên internet
Mã: 
Sub hidden()
Dim R As Range, CHK As Boolean
For Each R In Sheet1.Range(“A1:A10”)
CHK = False
If VarType(R.Value) = vbError Then
CHK = True
Else
If R.Value = “” Then CHK = True
End If
R.Entirerow.Hidden = CHK
Next
Set R = Nothing
End Sub
Code hiện tại 1 bài viết trên internet :
Mã: 
Sub ShowRows()
Sheet1.Range(“A1:A100”).EntireRow.Hidden = False
End Sub
Tuy nhiên, chắc là của mình phức tạp hơn 1 chút và cũng đang đau đầu tìm cách giải quyết mà vẫn chưa ra nên rất mong đc chỉ giáo
Mình xin chân thành cảm ơn các bác đã xem qua và hỗ trợ mình ạ
 
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

Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
25
Đọc
529
tle2003
T
vuongnlks
Lấy dữ liệu 1 cột cụ thể theo ngày từ nhiều file CSV ứng với mã tương ứng trong cột MA CO PHIEU
Trả lời
1
Đọc
70
BuiQuangThuan
B
V
Hỗ trợ hàm Sumproduct và Subtotal trong GG Sheets
Trả lời
3
Đọc
225
nguyenngocphuongsw
nguyenngocphuongsw
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
10
Đọc
207
tle2003
T
K
Tính tổng có điều kiện
Trả lời
4
Đọc
156
kimson_nb
K
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