Xuất dữ liệu từ điều kiện, thông tin ở 2 sheet ra nhiều sheet

Liên hệ QC
S

stao

Thành viên hoạt động
Tham gia
29/7/08
Bài viết
113
Được thích
26
Chào các Bác,

Em đang tìm hiểu về Scripting Dictionary. Bài tập đính kèm đã hỏi trên GPE nhưng còn vướng một chút là Data 2 có nhiều hơn 1 cột cần truy xuất thông tin thì chưa biết cách làm code thế nào.

1. Data1: id là điều kiện để liên kết với Data2, guest là điều kiện để liên quan sheet
2. Data2: từ id có thêm nhiều thông tin chi tiết liên quan
3. Các sheet (Alpha, Beta, Delta): Được đổ dữ liệu theo điều kiện guest từ 2 sheet Data 1 và 2
4. Sheet gama: Các guest còn lại sẽ đổ vào đây

Nhờ các Bác hướng dẫn giúp. Xin cảm ơn nhiều.
 

File đính kèm

  • Copy du lieu ra cac sheet thoa dk.xlsb
    26.5 KB · Đọc: 19
stao đã viết:
Chào các Bác,

Em đang tìm hiểu về Scripting Dictionary. Bài tập đính kèm đã hỏi trên GPE nhưng còn vướng một chút là Data 2 có nhiều hơn 1 cột cần truy xuất thông tin thì chưa biết cách làm code thế nào.
Nhấp chuột vào đây để mở rộng...

Add vào Dic cái ID tại Data2 này. -> Vì cơ bản dữ liệu tại Data2 này đã là duy nhất cái ID rồi.
Ví dụ
Mã: 
For I = 1 To UBound(ArrData2)
       Dic.Item(ArrData2(I, 1)) = I
Next

Sau đó muốn truy xuất giá trị các cột ở Data2 thì thông qua ID đã add vào Dic
Ví dụ
Mã: 
If Dic.exists(ArrData1(I, 1)) Then
      sArr(K, 3) = ArrData2(Dic.Item(ArrData1(I, 1)), 3)
Else
      sArr(K, 3) = Empty
End If
Ghi chú: code của bạn còn luộm thuộm và dài dòng quá -> nên rút gọn lại.
 
hpkhuong đã viết:
Add vào Dic cái ID tại Data2 này. -> Vì cơ bản dữ liệu tại Data2 này đã là duy nhất cái ID rồi.
Ví dụ
Mã: 
For I = 1 To UBound(ArrData2)
       Dic.Item(ArrData2(I, 1)) = I
Next

Sau đó muốn truy xuất giá trị các cột ở Data2 thì thông qua ID đã add vào Dic
Ví dụ
Mã: 
If Dic.exists(ArrData1(I, 1)) Then
      sArr(K, 3) = ArrData2(Dic.Item(ArrData1(I, 1)), 3)
Else
      sArr(K, 3) = Empty
End If
Ghi chú: code của bạn còn luộm thuộm và dài dòng quá -> nên rút gọn lại.
Nhấp chuột vào đây để mở rộng...
Cảm ơn Bác. Em đã làm được. Vì mới tiếp cận Scripting Dictionary này nên cũng chưa rành cách hoạt động của nó lắm.
Khi chỉnh code theo ý Bác thì file chạy chậm chút. Cũng chưa rõ phải rút gọn code sau nữa. Nếu Bác có thời gian thì nhờ Bác giúp ạ
 
stao đã viết:
Cảm ơn Bác. Em đã làm được. Vì mới tiếp cận Scripting Dictionary này nên cũng chưa rành cách hoạt động của nó lắm.
Khi chỉnh code theo ý Bác thì file chạy chậm chút. Cũng chưa rõ phải rút gọn code sau nữa. Nếu Bác có thời gian thì nhờ Bác giúp ạ
Nhấp chuột vào đây để mở rộng...
Rút gọn một chút:
PHP: 
Public Sub GPE()
Dim Dic As Object, ArrData1(), ArrData2(), Tmp(), Txt As String, ShName As String
Dim I As Long, J As Long, K As Long, N As Long, R As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
'------------------------------------Gan Id ArrData2 vao Dic'
    Tmp = Range("J1:M2").Value
    ArrData1 = Sheets("Data1").Range("A5", Sheets("Data1").Range("A5").End(xlDown)).Resize(, 6).Value
    R = UBound(ArrData1)
    ArrData2 = Sheets("Data2").Range("A5").Resize(R, 4).Value
    For I = 1 To UBound(ArrData2)
        Dic.Item(ArrData2(I, 1)) = I
    Next I
'---------------------------------------Lay du lieu cho 3 sheet dieu kien J2:L2 (A,B,C)'
For N = 1 To 3
    ReDim dArr(1 To R, 1 To 7)
    ShName = Tmp(1, N)
    Txt = Tmp(2, N)
    K = 0
    For I = 1 To R
        If ArrData1(I, 6) = Txt Then
            K = K + 1
            dArr(K, 1) = ArrData1(I, 1)
            dArr(K, 2) = ArrData1(I, 2)
            dArr(K, 4) = "GPE"
            dArr(K, 5) = ArrData1(I, 3)
            dArr(K, 6) = ArrData1(I, 5)
            ArrData1(I, 6) = Empty  '-------------------Xoa guest A,B,C'
            If Dic.Exists(ArrData1(I, 1)) Then
                Rws = Dic.Item(ArrData1(I, 1))
                dArr(K, 3) = ArrData2(Rws, 3)
                dArr(K, 7) = ArrData2(Rws, 4)
            End If
        End If
    Next I
    Sheets(ShName).Range("A5").Resize(100, 7).ClearContents
    If K Then Sheets(ShName).Range("A5").Resize(K, 7) = dArr
Next N
'---------------------------------------Lay du lieu cho sheet dieu kien M2 (Khac)'
ReDim dArr(1 To R, 1 To 7)
ShName = Tmp(1, 4)
K = 0
For I = 1 To R
    If ArrData1(I, 6) <> Empty Then 'Lay guest con lai'
        K = K + 1
            dArr(K, 1) = ArrData1(I, 1)
            dArr(K, 2) = ArrData1(I, 2)
            dArr(K, 4) = "GPE"
            dArr(K, 5) = ArrData1(I, 3)
            dArr(K, 6) = ArrData1(I, 5)
        If Dic.Exists(ArrData1(I, 1)) Then
            Rws = Dic.Item(ArrData1(I, 1))
            dArr(K, 3) = ArrData2(Rws, 3)
            dArr(K, 7) = ArrData2(Rws, 4)
        End If
    End If
Next I
With Sheets(ShName)
    .Range("A5").Resize(100, 7).ClearContents
    If K Then .Range("A5").Resize(K, 7) = dArr
End With
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
stao đã viết:
Cảm ơn Bác. Em đã làm được. Vì mới tiếp cận Scripting Dictionary này nên cũng chưa rành cách hoạt động của nó lắm.
Khi chỉnh code theo ý Bác thì file chạy chậm chút. Cũng chưa rõ phải rút gọn code sau nữa. Nếu Bác có thời gian thì nhờ Bác giúp ạ
Nhấp chuột vào đây để mở rộng...
Học code lỏm nên vấn đề chạy chậm không thành vấn đề. Miễn là chính xác trước đã -> tốc độ sau.
Tôi rút gọn thành như vầy:
Mã: 
Public Sub GPE()
Dim Dic As Object, ArrData1(), ArrData2(), Tmp(), ShName As String, ShK As String
Dim I As Long, J As Long, K As Long, DicS As Object, sArr, kArr, K1 As Long

Set Dic = CreateObject("Scripting.Dictionary")
Set DicS = CreateObject("Scripting.Dictionary")
Tmp = Range("J1:M2").Value
ArrData1 = Sheets("Data1").Range("A5", Sheets("Data1").Range("A5").End(xlDown)).Resize(, 6).Value
ArrData2 = Sheets("Data2").Range("A5", Sheets("Data2").Range("A5").End(xlDown)).Resize(, 4).Value

    For I = 1 To UBound(ArrData2)
        Dic.Item(ArrData2(I, 1)) = I
    Next
    
    For I = 1 To UBound(Tmp, 2)
        DicS.Item(Tmp(2, I)) = I
    Next
    
ReDim sArr(1 To UBound(ArrData1), 1 To 8)
ReDim kArr(1 To UBound(ArrData1), 1 To 8)

For J = 1 To UBound(Tmp, 2)
K = 0: K1 = 0
    For I = 1 To UBound(ArrData1)
        If DicS.exists(ArrData1(I, 6)) Then
            If ArrData1(I, 6) = Tmp(2, J) Then
                K = K + 1
                sArr(K, 1) = ArrData1(I, 1)
                sArr(K, 2) = ArrData1(I, 2)
                If Dic.exists(ArrData1(I, 1)) Then
                    sArr(K, 3) = ArrData2(Dic.Item(ArrData1(I, 1)), 3)
                Else
                    sArr(K, 3) = Empty
                End If
                sArr(K, 4) = "GPE"
                sArr(K, 5) = ArrData1(I, 3)
                sArr(K, 6) = ArrData1(I, 5)
                If Dic.exists(ArrData1(I, 1)) Then
                    sArr(K, 7) = ArrData2(Dic.Item(ArrData1(I, 1)), 4)
                Else
                    sArr(K, 7) = Empty
                End If
                sArr(K, 8) = ArrData1(I, 6)
                ShName = Tmp(1, J)
            End If
        Else
                K1 = K1 + 1
                kArr(K1, 1) = ArrData1(I, 1)
                kArr(K1, 2) = ArrData1(I, 2)
                If Dic.exists(ArrData1(I, 1)) Then
                    kArr(K1, 3) = ArrData2(Dic.Item(ArrData1(I, 1)), 3)
                Else
                    kArr(K1, 3) = Empty
                End If
                kArr(K1, 4) = "GPE"
                kArr(K1, 5) = ArrData1(I, 3)
                kArr(K1, 6) = ArrData1(I, 5)
                If Dic.exists(ArrData1(I, 1)) Then
                    kArr(K1, 7) = ArrData2(Dic.Item(ArrData1(I, 1)), 4)
                Else
                    kArr(K1, 7) = Empty
                End If
                kArr(K1, 8) = ArrData1(I, 6)
                ShK = Tmp(1, 4)
        End If
    Next
    If K Then Sheets(ShName).Range("A5").Resize(K, 8) = sArr
    If K1 Then Sheets(ShK).Range("A5").Resize(K1, 8) = kArr
Next
End Sub
 
Cảm ơn hai Bác, em đã chạy thử. Kết quả ngon lành ạ.
 
Em chào cả nhà. Các bác bớt chút thời gian giúp em cái Form sửa và nhập dữ liệu này với ah. Em có gửi File kèm theo. Em cảm ơn các bác nhiều
 

File đính kèm

  • Nhap_lich_xe_2018.rar
    54 KB · Đọc: 2
tonnydung đã viết:
Em chào cả nhà. Các bác bớt chút thời gian giúp em cái Form sửa và nhập dữ liệu này với ah. Em có gửi File kèm theo. Em cảm ơn các bác nhiều
Nhấp chuột vào đây để mở rộng...

Bạn vi phạm nội quy 2 vấn đề sau:
1/ Tiêu đề của chủ Topic là "Xuất dữ liệu từ điều kiện, thông tin ở 2 sheet ra nhiều sheet" đâu có liên quan gì đến cái vụ UserForm mà bạn lại chen ngang.
2/ Không nên đăng cùng nội dung với nhiều bài viết ở nhiều nơi, bài 145 của bạn ở Link sau:
https://www.giaiphapexcel.com/diendan/threads/các-câu-hỏi-về-form-trong-excel-vba.58794/page-8
 
be09 đã viết:
Bạn vi phạm nội quy 2 vấn đề sau:
1/ Tiêu đề của chủ Topic là "Xuất dữ liệu từ điều kiện, thông tin ở 2 sheet ra nhiều sheet" đâu có liên quan gì đến cái vụ UserForm mà bạn lại chen ngang.
2/ Không nên đăng cùng nội dung với nhiều bài viết ở nhiều nơi, bài 145 của bạn ở Link sau:
https://www.giaiphapexcel.com/diendan/threads/các-câu-hỏi-về-form-trong-excel-vba.58794/page-8
Nhấp chuột vào đây để mở rộng...
Vâng em đăng nhầm. Bác qua bên này xem và giúp em với ah. Tks bác : https://www.giaiphapexcel.com/diendan/threads/các-câu-hỏi-về-form-trong-excel-vba.58794/page-8
 
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

A
Excel thiếu dữ liệu
Trả lời
4
Đọc
107
Mr.hieudoanxd
Mr.hieudoanxd
H
  • Question
Code subtotal và tìm điều kiện
Trả lời
11
Đọc
194
Hoàng Tuấn 868
H
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
1
Đọc
50
BuiQuangThuan
B
A
Đếm dữ liệu với điều kiện
Trả lời
11
Đọc
118
DeTong
D
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
29
Đọc
2K
vu_tuan_manh_linh
vu_tuan_manh_linh
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