Xin code VBA Vlookup cho file báo cáo (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
D

dinhquang042000

Thành viên chính thức
Tham gia
16/12/15
Bài viết
76
Được thích
4
Mong các anh/chị Pro giúp em,

em có file báo cáo, khi đổ dữ liệu vào sheet CMS, chạy Macro module 2, sẽ cho 2 giá trị theo 2 pa tương ứng vào sheet NXLQ và DORU,
chạy thêm Macro module 3. file sẽ lọc và coppy các giá trị conts trùng nhau ở 2 sheet NXLQ và DORU sang sheet NXLQ - DORU,
Em muốn tạo code VBA để tự động lấy thông tin tương ứng các conts từ sheet DORU sang sheet NXLQ - DORU.
Mong nhận được sự trợ giúp từ các anh/chị.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
dinhquang042000 đã viết:
Mong các anh/chị Pro giúp em,

em có file báo cáo, khi đổ dữ liệu vào sheet CMS, chạy Macro module 2, sẽ cho 2 giá trị theo 2 pa tương ứng vào sheet NXLQ và DORU,
chạy thêm Macro module 3. file sẽ lọc và coppy các giá trị conts trùng nhau ở 2 sheet NXLQ và DORU sang sheet NXLQ - DORU,
Em muốn tạo code VBA để tự động lấy thông tin tương ứng các conts từ sheet DORU sang sheet NXLQ - DORU.
Mong nhận được sự trợ giúp từ các anh/chị.
Nhấp chuột vào đây để mở rộng...
xóa tất cả code cũ, chạy code nầy thực hiện tất cả công việc trên
Mã: 
Sub GPE()
Dim Darr, NXarr, DOarr, NDarr, Dic As Object
Dim i As Long, k As Long, n As Long
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B2:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim NXarr(1 To UBound(Darr), 1 To 6)
ReDim DOarr(1 To UBound(Darr), 1 To 6)
ReDim NDarr(1 To UBound(Darr), 1 To 6)
For i = 1 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        NXarr(k, 1) = Darr(i, 1): NXarr(k, 2) = Darr(i, 2)
        NXarr(k, 3) = Darr(i, 7): NXarr(k, 4) = Darr(i, 8)
        NXarr(k, 5) = Darr(i, 11): NXarr(k, 6) = Darr(i, 12)
        If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        n = n + 1
        DOarr(n, 1) = Darr(i, 1): DOarr(n, 2) = Darr(i, 2)
        DOarr(n, 3) = Darr(i, 7): DOarr(n, 4) = Darr(i, 8)
        DOarr(n, 5) = Darr(i, 11): DOarr(n, 6) = Darr(i, 12)
    End If
Next i
With Sheets("NXLQ")
    .Range("A3:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A3").Resize(k, 6) = NXarr
End With
With Sheets("DORU")
    .Range("A3:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A3").Resize(n, 6) = DOarr
End With
k = 0
For i = 1 To n
    If Dic.Exists(DOarr(i, 1)) Then
        k = k + 1
        NDarr(k, 1) = DOarr(i, 1): NDarr(k, 2) = DOarr(i, 2)
        NDarr(k, 3) = DOarr(i, 3): NDarr(k, 4) = DOarr(i, 4)
        NDarr(k, 5) = DOarr(i, 5): NDarr(k, 6) = DOarr(i, 6)
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A2:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A2").Resize(k, 6) = NDarr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
hpkhuong đã viết:
Hãy chú ý đoạn này:

Có thiêu thiếu gì không ta???
Nhấp chuột vào đây để mở rộng...
ghi nhận conts của sheet NXLQ vào DIC
Mã: 
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        NXarr(k, 1) = Darr(i, 1): NXarr(k, 2) = Darr(i, 2)
        NXarr(k, 3) = Darr(i, 7): NXarr(k, 4) = Darr(i, 8)
        NXarr(k, 5) = Darr(i, 11): NXarr(k, 6) = Darr(i, 12)
        [COLOR=#ff0000]If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""[/COLOR]
    End If
xét trùng Conts sheet NXLQ và sheet DORU và ghi vào sheet NXLQ - DORU
Mã: 
[FONT=Verdana]For i = 1 To n[/FONT]
    If [COLOR=#ff0000]Dic.Exists(DOarr(i, 1))[/COLOR] Then
        k = k + 1
        NDarr(k, 1) = DOarr(i, 1): NDarr(k, 2) = DOarr(i, 2)
        NDarr(k, 3) = DOarr(i, 3): NDarr(k, 4) = DOarr(i, 4)
        NDarr(k, 5) = DOarr(i, 5): NDarr(k, 6) = DOarr(i, 6)
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A2:F" & .Range("A3").End(xlDown).Row).ClearContents
    [COLOR=#ff0000].Range("A2").Resize(k, 6) = NDarr[/COLOR]
End With
nếu còn sót gì bạn hướng dẫn thêm, cám ơn
 
Upvote 0
HieuCD đã viết:
xóa tất cả code cũ, chạy code nầy thực hiện tất cả công việc trên
Mã: 
Sub GPE()
Dim Darr, NXarr, DOarr, NDarr, Dic As Object
Dim i As Long, k As Long, n As Long
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B2:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim NXarr(1 To UBound(Darr), 1 To 6)
ReDim DOarr(1 To UBound(Darr), 1 To 6)
ReDim NDarr(1 To UBound(Darr), 1 To 6)
For i = 1 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        NXarr(k, 1) = Darr(i, 1): NXarr(k, 2) = Darr(i, 2)
        NXarr(k, 3) = Darr(i, 7): NXarr(k, 4) = Darr(i, 8)
        NXarr(k, 5) = Darr(i, 11): NXarr(k, 6) = Darr(i, 12)
        If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        n = n + 1
        DOarr(n, 1) = Darr(i, 1): DOarr(n, 2) = Darr(i, 2)
        DOarr(n, 3) = Darr(i, 7): DOarr(n, 4) = Darr(i, 8)
        DOarr(n, 5) = Darr(i, 11): DOarr(n, 6) = Darr(i, 12)
    End If
Next i
With Sheets("NXLQ")
    .Range("A3:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A3").Resize(k, 6) = NXarr
End With
With Sheets("DORU")
    .Range("A3:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A3").Resize(n, 6) = DOarr
End With
k = 0
For i = 1 To n
    If Dic.Exists(DOarr(i, 1)) Then
        k = k + 1
        NDarr(k, 1) = DOarr(i, 1): NDarr(k, 2) = DOarr(i, 2)
        NDarr(k, 3) = DOarr(i, 3): NDarr(k, 4) = DOarr(i, 4)
        NDarr(k, 5) = DOarr(i, 5): NDarr(k, 6) = DOarr(i, 6)
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A2:F" & .Range("A3").End(xlDown).Row).ClearContents
    .Range("A2").Resize(k, 6) = NDarr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Anh cho em hỏi, Nếu em muốn coppy cả tiêu đề như socont, kichco, pa,... sang cac sheet NXLQ, DORU, NXLQ - DORU thì thêm code thế nào ạ
 
Upvote 0
dinhquang042000 đã viết:
Anh cho em hỏi, Nếu em muốn coppy cả tiêu đề như socont, kichco, pa,... sang cac sheet NXLQ, DORU, NXLQ - DORU thì thêm code thế nào ạ
Nhấp chuột vào đây để mở rộng...
bạn kiểm tra lại code
Mã: 
Sub GPE1()
Dim Darr, NXarr, DOarr, NDarr, Dic As Object
Dim i As Long, k As Long, n As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim NXarr(1 To UBound(Darr), 1 To 6)
ReDim DOarr(1 To UBound(Darr), 1 To 6)
ReDim NDarr(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    NXarr(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    DOarr(1, J) = NXarr(1, J): NDarr(1, J) = NXarr(1, J)
Next J
k = 1: n = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            NXarr(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        n = n + 1
        For J = 1 To 6
            DOarr(n, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NXarr
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(n + 1, 6) = DOarr
End With
k = 1
For i = 2 To n
    If Dic.Exists(DOarr(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            NDarr(k, J) = DOarr(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NDarr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
HieuCD đã viết:
bạn kiểm tra lại code
Mã: 
Sub GPE1()
Dim Darr, NXarr, DOarr, NDarr, Dic As Object
Dim i As Long, k As Long, n As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim NXarr(1 To UBound(Darr), 1 To 6)
ReDim DOarr(1 To UBound(Darr), 1 To 6)
ReDim NDarr(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    NXarr(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    DOarr(1, J) = NXarr(1, J): NDarr(1, J) = NXarr(1, J)
Next J
k = 1: n = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            NXarr(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        n = n + 1
        For J = 1 To 6
            DOarr(n, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NXarr
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(n + 1, 6) = DOarr
End With
k = 1
For i = 2 To n
    If Dic.Exists(DOarr(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            NDarr(k, J) = DOarr(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NDarr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn anh rất nhiều, code rất hay ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
bạn kiểm tra lại code
Mã: 
Sub GPE1()
Dim Darr, NXarr, DOarr, NDarr, Dic As Object
Dim i As Long, k As Long, n As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim NXarr(1 To UBound(Darr), 1 To 6)
ReDim DOarr(1 To UBound(Darr), 1 To 6)
ReDim NDarr(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    NXarr(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    DOarr(1, J) = NXarr(1, J): NDarr(1, J) = NXarr(1, J)
Next J
k = 1: n = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            NXarr(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(NXarr(k, 1)) Then Dic.Add NXarr(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        n = n + 1
        For J = 1 To 6
            DOarr(n, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NXarr
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(n + 1, 6) = DOarr
End With
k = 1
For i = 2 To n
    If Dic.Exists(DOarr(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            NDarr(k, J) = DOarr(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = NDarr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Dear A Hiếu CD,

cảm ơn code của anh rất nhiều, em muốn chỉnh sửa code để mở rộng thêm các phương án (dile đính kèm),
thêm sheet CAPR, CXLA, tương tự sheet DORU,
Sheet NXLQ - CAPR, NXLQ - CXLA giống cách làm sheet NXLQ - DORU,
(NXLQ - CAPR là giá trị chung của NXLQ và CAPR)
(NXLQ - CXLA là giá trị chung của NXLQ và CXLA)

Mong nhận được sự chỉ giáo của anh
Em xin chân thành cảm ơn.
 
Upvote 0
dinhquang042000 đã viết:
Dear A Hiếu CD,
thêm sheet CAPR, CXLA, tương tự sheet DORU,
Sheet NXLQ - CAPR, NXLQ - CXLA giống cách làm sheet NXLQ - DORU,
(NXLQ - CAPR là giá trị chung của NXLQ và CAPR)
(NXLQ - CXLA là giá trị chung của NXLQ và CXLA)
Nhấp chuột vào đây để mở rộng...
Code dài và lặp lại, nhưng bạn dể áp dụng, khi rảnh mình sẽ rút gọn lại bằng code phụ
Chú ý, bạn phải tạo 4 sheet và đặt tên cho đúng mới chạy được code
Mã: 
Sub GPE1()
Dim Darr, arrNX(), arrDO(), arrCA(), arrCX(), arrNX_DO(), arrNX_CA(), arrNX_CX(), Dic As Object
Dim i As Long, k As Long, nDO As Long, nCA As Long, nCX  As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim arrNX(1 To UBound(Darr), 1 To 6): ReDim arrDO(1 To UBound(Darr), 1 To 6)
ReDim arrCA(1 To UBound(Darr), 1 To 6): ReDim arrCX(1 To UBound(Darr), 1 To 6)
ReDim arrNX_DO(1 To UBound(Darr), 1 To 6): ReDim arrNX_CA(1 To UBound(Darr), 1 To 6)
ReDim arrNX_CX(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
    arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
    arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        nDO = nDO + 1
        For J = 1 To 6
            arrDO(nDO, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CAPR" Then
        nCA = nCA + 1
        For J = 1 To 6
            arrCA(nCA, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CXLA" Then
        nCX = nCX + 1
        For J = 1 To 6
            arrCX(nCX, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nDO + 1, 6) = arrDO
End With
With Sheets("CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCA + 1, 6) = arrCA
End With
With Sheets("CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCX + 1, 6) = arrCX
End With
k = 1
For i = 2 To nDO
    If Dic.Exists(arrDO(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_DO(k, J) = arrDO(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_DO
End With
k = 1
For i = 2 To nCA
    If Dic.Exists(arrCA(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CA(k, J) = arrCA(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CA
End With
k = 1
For i = 2 To nCX
    If Dic.Exists(arrCX(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CX(k, J) = arrCX(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CX
End With
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Code dài và lặp lại, nhưng bạn dể áp dụng, khi rảnh mình sẽ rút gọn lại bằng code phụ
Chú ý, bạn phải tạo 4 sheet và đặt tên cho đúng mới chạy được code
Mã: 
Sub GPE1()
Dim Darr, arrNX(), arrDO(), arrCA(), arrCX(), arrNX_DO(), arrNX_CA(), arrNX_CX(), Dic As Object
Dim i As Long, k As Long, nDO As Long, nCA As Long, nCX  As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim arrNX(1 To UBound(Darr), 1 To 6): ReDim arrDO(1 To UBound(Darr), 1 To 6)
ReDim arrCA(1 To UBound(Darr), 1 To 6): ReDim arrCX(1 To UBound(Darr), 1 To 6)
ReDim arrNX_DO(1 To UBound(Darr), 1 To 6): ReDim arrNX_CA(1 To UBound(Darr), 1 To 6)
ReDim arrNX_CX(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
    arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
    arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        nDO = nDO + 1
        For J = 1 To 6
            arrDO(nDO, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CAPR" Then
        nCA = nCA + 1
        For J = 1 To 6
            arrCA(nCA, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CXLA" Then
        nCX = nCX + 1
        For J = 1 To 6
            arrCX(nCX, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nDO + 1, 6) = arrDO
End With
With Sheets("CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCA + 1, 6) = arrCA
End With
With Sheets("CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCX + 1, 6) = arrCX
End With
k = 1
For i = 2 To nDO
    If Dic.Exists(arrDO(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_DO(k, J) = arrDO(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_DO
End With
k = 1
For i = 2 To nCA
    If Dic.Exists(arrCA(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CA(k, J) = arrCA(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CA
End With
k = 1
For i = 2 To nCX
    If Dic.Exists(arrCX(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CX(k, J) = arrCX(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CX
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ em Cảm ơn anh rất nhiều ạ.
 
Upvote 0
HieuCD đã viết:
Code dài và lặp lại, nhưng bạn dể áp dụng, khi rảnh mình sẽ rút gọn lại bằng code phụ
Chú ý, bạn phải tạo 4 sheet và đặt tên cho đúng mới chạy được code
Mã: 
Sub GPE1()
Dim Darr, arrNX(), arrDO(), arrCA(), arrCX(), arrNX_DO(), arrNX_CA(), arrNX_CX(), Dic As Object
Dim i As Long, k As Long, nDO As Long, nCA As Long, nCX  As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim arrNX(1 To UBound(Darr), 1 To 6): ReDim arrDO(1 To UBound(Darr), 1 To 6)
ReDim arrCA(1 To UBound(Darr), 1 To 6): ReDim arrCX(1 To UBound(Darr), 1 To 6)
ReDim arrNX_DO(1 To UBound(Darr), 1 To 6): ReDim arrNX_CA(1 To UBound(Darr), 1 To 6)
ReDim arrNX_CX(1 To UBound(Darr), 1 To 6)
For J = 1 To 6
    arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
    arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
    arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
    arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For J = 1 To 6
            arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
        If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        nDO = nDO + 1
        For J = 1 To 6
            arrDO(nDO, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CAPR" Then
        nCA = nCA + 1
        For J = 1 To 6
            arrCA(nCA, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
    If Darr(i, 8) = "CXLA" Then
        nCX = nCX + 1
        For J = 1 To 6
            arrCX(nCX, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
        Next J
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nDO + 1, 6) = arrDO
End With
With Sheets("CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCA + 1, 6) = arrCA
End With
With Sheets("CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCX + 1, 6) = arrCX
End With
k = 1
For i = 2 To nDO
    If Dic.Exists(arrDO(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_DO(k, J) = arrDO(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_DO
End With
k = 1
For i = 2 To nCA
    If Dic.Exists(arrCA(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CA(k, J) = arrCA(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CA
End With
k = 1
For i = 2 To nCX
    If Dic.Exists(arrCX(i, 1)) Then
        k = k + 1
        For J = 1 To 6
            arrNX_CX(k, J) = arrCX(i, J)
        Next J
    End If
Next i
With Sheets("NXLQ - CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CX
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ em cảm ơn anh vì bài viết rất nhiều ạ,
 
Upvote 0
doveandrose đã viết:
kim tự tháp Ai Cập , thật là cao siêu hùng vĩ , ghê thặc !$@!!!$@!!!$@!!
Nhấp chuột vào đây để mở rộng...
Code mới ngắn hơn, nhưng chạy chậm hơn
chạy Sub Main
Mã: 
Dim Darr, Dic As Object
Dim i As Long, k As Long, n As Long, j As Integer, tmp As Integer

Sub Main()
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
tmp = 1
Call aadArr("NXLQ", "NXLQ - NXLQ")
tmp = 2
Call aadArr("DORU", "NXLQ - DORU")
Call aadArr("CAPR", "NXLQ - CAPR")
Call aadArr("CXLA", "NXLQ - CXLA")
Set Dic = Nothing
End Sub

Sub aadArr(sh As String, sh_sh As String)
Dim arrSh(), arrSh_Sh()
ReDim arrSh(1 To UBound(Darr), 1 To 6): ReDim arrSh_Sh(1 To UBound(Darr), 1 To 6)
For j = 1 To 6
    arrSh(1, j) = Darr(1, Choose(j, 1, 2, 7, 8, 11, 12))
    If tmp = 2 Then arrSh_Sh(1, j) = arrSh(1, j)
Next j
k = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = sh Then
        k = k + 1
        For j = 1 To 6
            arrSh(k, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
        If tmp = 1 Then
            If Not Dic.Exists(arrSh(k, 1)) Then Dic.Add arrSh(k, 1), ""
        End If
    End If
Next i
With Sheets(sh)
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrSh
End With
If tmp = 2 Then
    n = 1
    For i = 2 To k
        If Dic.Exists(arrSh(i, 1)) Then
            n = n + 1
            For j = 1 To 6
                arrSh_Sh(n, j) = arrSh(i, j)
            Next j
        End If
    Next i
    With Sheets(sh_sh)
        .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
        .Range("A1").Resize(n + 1, 6) = arrSh_Sh
    End With
End If
End Sub
nhờ bạn ra tay viết code ngắn đồng thời vẫn chạy nhanh để học hỏi
 
Upvote 0
HieuCD đã viết:
nhờ bạn ra tay viết code ngắn đồng thời vẫn chạy nhanh để học hỏi
Nhấp chuột vào đây để mở rộng...

ặc , chuyên gia nói dóc như mình có gì để cho bạn học hỏi chứ , bạn nên kiếm anh HpKhuong ở trên kìa .
Mà theo mình thấy thì các bạn ở trên hình như đang lái xe đi lạc đường rồi hay sao ấy . Bạn có nhìn thấy Trong file #1 có sheet SQL , sheet này có cái hình to đùng , tô màu , phiên âm đồ rất là đẹp đẽ

d08197795af3ddbca0fa0026002b2ee0.png


Người làm ra file này chỉ muốn code bằng cú pháp SQL thôi mà , đâu có liên quan gì đến mảng hay là Dictionary gì đâu . !$@!!!$@!!

Trong mấy sheet đơn thì đã có lệnh ở ô A1 rồi , muốn ghép 2 sheet lại với nhau thì xài lệnh Inner Join là xong
Ô A1 đã có các lệnh SQL sẵn rồi thì nên tìm hiểu thêm 1 chút mà tự hoàn thiện file , trường hợp này mình chỉ gợi ý cho tác giả của file tự làm , còn ai muốn viết luôn code dùm họ thì tùy .
 
Upvote 0
doveandrose đã viết:
ặc , chuyên gia nói dóc như mình có gì để cho bạn học hỏi chứ , bạn nên kiếm anh HpKhuong ở trên kìa .
Mà theo mình thấy thì các bạn ở trên hình như đang lái xe đi lạc đường rồi hay sao ấy . Bạn có nhìn thấy Trong file #1 có sheet SQL , sheet này có cái hình to đùng , tô màu , phiên âm đồ rất là đẹp đẽ

d08197795af3ddbca0fa0026002b2ee0.png


Người làm ra file này chỉ muốn code bằng cú pháp SQL thôi mà , đâu có liên quan gì đến mảng hay là Dictionary gì đâu . !$@!!!$@!!

Trong mấy sheet đơn thì đã có lệnh ở ô A1 rồi , muốn ghép 2 sheet lại với nhau thì xài lệnh Inner Join là xong
Ô A1 đã có các lệnh SQL sẵn rồi thì nên tìm hiểu thêm 1 chút mà tự hoàn thiện file , trường hợp này mình chỉ gợi ý cho tác giả của file tự làm , còn ai muốn viết luôn code dùm họ thì tùy .
Nhấp chuột vào đây để mở rộng...
viết SQL ngắn hơn, mình đã chạy thử vài code bằng SQL của nhiều bạn, hình như chạy chậm hơn code VBA không biết đúng không?
 
Upvote 0
Dear A Hieu

1. vì dữ liệu đôi lúc thay đổi. Nếu em muốn thay đổi cột lấy giá trị thì thay đổi số ở đoạn code này đúng ko anh,
arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
If Darr(i, 8) = "NXLQ" Then
k = k + 1
For J = 1 To 6
arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
Next J
If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""

VD: từ lấy dữ liệu côt B,C,H,I,L,M sang cột B,C,K,L,O,P
em thay đoạn Choose(J, 1, 2, 7, 8, 11, 12)) thành Choose(J, 1, 2, 10, 11, 14, 15))
Đúng ko ạ.

2. Nếu lọc ra các giá trị trùng nhau sang sheet như NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR, có các giá trị trùng nhau, viết thêm code gì để xóa bớt đi các giá trị trùng nhau ạ
 
Lần chỉnh sửa cuối:
Upvote 0
dinhquang042000 đã viết:
Dear A Hieu

1. vì dữ liệu đôi lúc thay đổi. Nếu em muốn thay đổi cột lấy giá trị thì thay đổi số ở đoạn code này đúng ko anh,
arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
If Darr(i, 8) = "NXLQ" Then
k = k + 1
For J = 1 To 6
arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
Next J
If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""

VD: từ lấy dữ liệu côt B,C,H,I,L,M sang cột B,C,K,L,O,P
em thay đoạn Choose(J, 1, 2, 7, 8, 11, 12)) thành Choose(J, 1, 2, 10, 11, 14, 15))
Đúng ko ạ.

2. Nếu lọc ra các giá trị trùng nhau sang sheet như NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR, có các giá trị trùng nhau, viết thêm code gì để xóa bớt đi các giá trị trùng nhau ạ
Nhấp chuột vào đây để mở rộng...

Viết tặng bạn 2 Sub VBA, còn SQL thì tôi "thua".
PHP: 
Public Sub S_GPE1()
Dim sArr(), dArr(), tArr, I As Long, J As Long, K As Long, DK As String
With Sheets("CMS")
    sArr = .Range("B1", .Range("B1").End(xlDown)).Resize(, 12).Value
End With
tArr = Array(1, 2, 7, 8, 11, 12)
ReDim dArr(1 To UBound(sArr), 1 To 6)
DK = ActiveSheet.Name
For J = 0 To 5
    dArr(1, J + 1) = sArr(1, tArr(J))
Next J
K = 1
For I = 2 To UBound(sArr)
    If sArr(I, 8) = DK Then
        K = K + 1
        For J = 0 To 5
            dArr(K, J + 1) = sArr(I, tArr(J))
        Next J
    End If
Next I
Range("A2:F1000").ClearContents
Range("A2").Resize(K, 6) = dArr
End Sub
PHP: 
Public Sub S_GPE2()
Dim Dic As Object, sArr(), dAtt(), I As Long, K As Long
Dim Dk1 As String, Dk2 As String, Tem As String, shName
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("CMS")
    sArr = .Range("B2", .Range("B2").End(xlDown)).Resize(, 8).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 1)
shName = Split(ActiveSheet.Name, "-")
Dk1 = Trim(shName(0)): Dk2 = Trim(shName(1))
For I = 1 To UBound(sArr)
    If sArr(I, 8) = Dk1 Then
        If Not Dic.exists(sArr(I, 1)) Then Dic.Add sArr(I, 1), ""
    End If
Next I
For I = 1 To UBound(sArr)
    If sArr(I, 8) = Dk2 Then
        If Dic.exists(sArr(I, 1)) Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            Dic.Remove sArr(I, 1)
        End If
    End If
Next I
Range("A2:A1000").ClearContents
If K Then Range("A2").Resize(K) = dArr
Set Dic = Nothing
End Sub
Nhiệm vụ còn lại của bạn là gán cái này trong các sheet "Đơn", ví dụ "NXLQ","DORU",...............
PHP: 
Private Sub Worksheet_Activate()
S_GPE1
End Sub
Và cái này cho các sheet "Đôi" ví dụ "NXLQ-DORU",........................
PHP: 
Private Sub Worksheet_Activate()
S_GPE2
End Sub
Các cột muốn lấy số liệu cho các sheet "Đơn" là các cột có trong mảng này:
tArr = Array(1, 2, 7, 8, 11, 12)
Bạn có thể tuỳ chỉnh.
 

File đính kèm

Upvote 0
dinhquang042000 đã viết:
Dear A Hieu

1. vì dữ liệu đôi lúc thay đổi. Nếu em muốn thay đổi cột lấy giá trị thì thay đổi số ở đoạn code này đúng ko anh,
arrNX(1, J) = Darr(1, Choose(J, 1, 2, 7, 8, 11, 12))
arrDO(1, J) = arrNX(1, J): arrNX_DO(1, J) = arrNX(1, J)
arrCA(1, J) = arrNX(1, J): arrNX_CA(1, J) = arrNX(1, J)
arrCX(1, J) = arrNX(1, J): arrNX_CX(1, J) = arrNX(1, J)
Next J
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
If Darr(i, 8) = "NXLQ" Then
k = k + 1
For J = 1 To 6
arrNX(k, J) = Darr(i, Choose(J, 1, 2, 7, 8, 11, 12))
Next J
If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""

VD: từ lấy dữ liệu côt B,C,H,I,L,M sang cột B,C,K,L,O,P
em thay đoạn Choose(J, 1, 2, 7, 8, 11, 12)) thành Choose(J, 1, 2, 10, 11, 14, 15))
Đúng ko ạ.

2. Nếu lọc ra các giá trị trùng nhau sang sheet như NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR, có các giá trị trùng nhau, viết thêm code gì để xóa bớt đi các giá trị trùng nhau ạ
Nhấp chuột vào đây để mở rộng...
1. Choose(J, 1, 2, 10, 11, 14, 15): bạn đếm thứ tự cột tính từ cột B
2. xóa bớt đi các giá trị trùng nhau: Xóa ở cả 3 sheet NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR hay chỉ xóa ở sheet nào
 
Upvote 0
HieuCD đã viết:
1. Choose(J, 1, 2, 10, 11, 14, 15): bạn đếm thứ tự cột tính từ cột B
2. xóa bớt đi các giá trị trùng nhau: Xóa ở cả 3 sheet NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR hay chỉ xóa ở sheet nào
Nhấp chuột vào đây để mở rộng...

Dạ chỉ xóa các gí trị conts trùng nhau ở sheet NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR. Anh xem chỉ dẫn giúp e.
 
Upvote 0
dinhquang042000 đã viết:
Dạ chỉ xóa các gí trị conts trùng nhau ở sheet NXLQ - DORU, NXLQ - CXLA, NXLQ - CAPR. Anh xem chỉ dẫn giúp e.
Nhấp chuột vào đây để mở rộng...
Thấy bạn sử dụng code dài (có lợi điểm là thay đổi cột lấy dữ liệu trong từng sheet) nên mình thêm trong code dài.
đầu tiên nhập đầy đủ vào sheet NXLQ - DORU, nếu có trùng thì loại ở sheet NXLQ - CXLA rồi tới NXLQ - CAPR
Mã:
Mã: 
Sub GPE1()
Dim Darr, arrNX(), arrDO(), arrCA(), arrCX(), arrNX_DO(), arrNX_CA(), arrNX_CX(), Dic As Object, Dic_Dic As Object
Dim i As Long, k As Long, nDO As Long, nCA As Long, nCX  As Long, j As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim arrNX(1 To UBound(Darr), 1 To 6): ReDim arrDO(1 To UBound(Darr), 1 To 6)
ReDim arrCA(1 To UBound(Darr), 1 To 6): ReDim arrCX(1 To UBound(Darr), 1 To 6)
ReDim arrNX_DO(1 To UBound(Darr), 1 To 6): ReDim arrNX_CA(1 To UBound(Darr), 1 To 6)
ReDim arrNX_CX(1 To UBound(Darr), 1 To 6)
For j = 1 To 6
    arrNX(1, j) = Darr(1, Choose(j, 1, 2, 7, 8, 11, 12))
    arrDO(1, j) = arrNX(1, j): arrNX_DO(1, j) = arrNX(1, j)
    arrCA(1, j) = arrNX(1, j): arrNX_CA(1, j) = arrNX(1, j)
    arrCX(1, j) = arrNX(1, j): arrNX_CX(1, j) = arrNX(1, j)
Next j
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For j = 1 To 6
            arrNX(k, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
        If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        nDO = nDO + 1
        For j = 1 To 6
            arrDO(nDO, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
    If Darr(i, 8) = "CAPR" Then
        nCA = nCA + 1
        For j = 1 To 6
            arrCA(nCA, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
    If Darr(i, 8) = "CXLA" Then
        nCX = nCX + 1
        For j = 1 To 6
            arrCX(nCX, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nDO + 1, 6) = arrDO
End With
With Sheets("CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCA + 1, 6) = arrCA
End With
With Sheets("CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCX + 1, 6) = arrCX
End With
Set Dic_Dic = CreateObject("Scripting.Dictionary")
k = 1
For i = 2 To nDO
    If Dic.Exists(arrDO(i, 1)) Then
        If Not Dic_Dic.Exists(arrDO(i, 1)) Then
            Dic_Dic.Add arrDO(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_DO(k, j) = arrDO(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_DO
End With
k = 1
For i = 2 To nCA
    If Dic.Exists(arrCA(i, 1)) Then
        If Not Dic_Dic.Exists(arrCA(i, 1)) Then
            Dic_Dic.Add arrCA(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_CA(k, j) = arrCA(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CA
End With
k = 1
For i = 2 To nCX
    If Dic.Exists(arrCX(i, 1)) Then
        If Not Dic_Dic.Exists(arrCX(i, 1)) Then
            Dic_Dic.Add arrCX(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_CX(k, j) = arrCX(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CX
End With
Set Dic = Nothing
End Sub
sao không chỉ copy vào 1 sheet duy nhất để dể theo dõi?
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Thấy bạn sử dụng code dài (có lợi điểm là thay đổi cột lấy dữ liệu trong từng sheet) nên mình thêm trong code dài.
đầu tiên nhập đầy đủ vào sheet NXLQ - DORU, nếu có trùng thì loại ở sheet NXLQ - CXLA rồi tới NXLQ - CAPR
Mã:
Mã: 
Sub GPE1()
Dim Darr, arrNX(), arrDO(), arrCA(), arrCX(), arrNX_DO(), arrNX_CA(), arrNX_CX(), Dic As Object, Dic_Dic As Object
Dim i As Long, k As Long, nDO As Long, nCA As Long, nCX  As Long, j As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("CMS").Range("B1:M" & Sheets("CMS").Range("B2").End(xlDown).Row)
ReDim arrNX(1 To UBound(Darr), 1 To 6): ReDim arrDO(1 To UBound(Darr), 1 To 6)
ReDim arrCA(1 To UBound(Darr), 1 To 6): ReDim arrCX(1 To UBound(Darr), 1 To 6)
ReDim arrNX_DO(1 To UBound(Darr), 1 To 6): ReDim arrNX_CA(1 To UBound(Darr), 1 To 6)
ReDim arrNX_CX(1 To UBound(Darr), 1 To 6)
For j = 1 To 6
    arrNX(1, j) = Darr(1, Choose(j, 1, 2, 7, 8, 11, 12))
    arrDO(1, j) = arrNX(1, j): arrNX_DO(1, j) = arrNX(1, j)
    arrCA(1, j) = arrNX(1, j): arrNX_CA(1, j) = arrNX(1, j)
    arrCX(1, j) = arrNX(1, j): arrNX_CX(1, j) = arrNX(1, j)
Next j
k = 1: nDO = 1: nCA = 1: nCX = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "NXLQ" Then
        k = k + 1
        For j = 1 To 6
            arrNX(k, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
        If Not Dic.Exists(arrNX(k, 1)) Then Dic.Add arrNX(k, 1), ""
    End If
    If Darr(i, 8) = "DORU" Then
        nDO = nDO + 1
        For j = 1 To 6
            arrDO(nDO, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
    If Darr(i, 8) = "CAPR" Then
        nCA = nCA + 1
        For j = 1 To 6
            arrCA(nCA, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
    If Darr(i, 8) = "CXLA" Then
        nCX = nCX + 1
        For j = 1 To 6
            arrCX(nCX, j) = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j
    End If
Next i
With Sheets("NXLQ")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX
End With
With Sheets("DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nDO + 1, 6) = arrDO
End With
With Sheets("CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCA + 1, 6) = arrCA
End With
With Sheets("CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(nCX + 1, 6) = arrCX
End With
Set Dic_Dic = CreateObject("Scripting.Dictionary")
k = 1
For i = 2 To nDO
    If Dic.Exists(arrDO(i, 1)) Then
        If Not Dic_Dic.Exists(arrDO(i, 1)) Then
            Dic_Dic.Add arrDO(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_DO(k, j) = arrDO(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - DORU")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_DO
End With
k = 1
For i = 2 To nCA
    If Dic.Exists(arrCA(i, 1)) Then
        If Not Dic_Dic.Exists(arrCA(i, 1)) Then
            Dic_Dic.Add arrCA(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_CA(k, j) = arrCA(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - CAPR")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CA
End With
k = 1
For i = 2 To nCX
    If Dic.Exists(arrCX(i, 1)) Then
        If Not Dic_Dic.Exists(arrCX(i, 1)) Then
            Dic_Dic.Add arrCX(i, 1), ""
            k = k + 1
            For j = 1 To 6
                arrNX_CX(k, j) = arrCX(i, j)
            Next j
        End If
    End If
Next i
With Sheets("NXLQ - CXLA")
    .Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 6) = arrNX_CX
End With
Set Dic = Nothing
End Sub
sao không chỉ copy vào 1 sheet duy nhất để dể theo dõi?
Nhấp chuột vào đây để mở rộng...

Dear anh Hiếu,
Do phải xử lý dữ liệu thêm để ra báo cáo của từng phương án nên em mới tạo thành từng sheet để tiện cho lọc về sau

Anh cho em hỏi thêm 1 chút như sheet NXLQ - DORU, Nếu em muốn thay vì lấy các thông tin đi theo socont trùng nhau từ sheet DORU sang lấy thông tin NXLQ. thì thay đổi code đoạn mã nào ạ.
Em sửa đoạn này thì ko ra
k = 1For i = 2 To nDO
If Dic.Exists(arrDO(i, 1)) Then
k = k + 1
For J = 1 To 8
arrNH_DO(k, J) = arrDO(i, J)
Next J
End If
Next i
With Sheets("NXLQ - DORU")
.Range("A1:F" & .Range("A65500").End(xlUp).Row).ClearContents
.Range("A1").Resize(k + 1, 8) = arrNH_DO
End With


Mong anh chỉ giáo thêm,
 
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

SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng (1 người xem)
Trả lời
13
Đọc
228
SA_DQ
SA_DQ
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
132
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
2
Đọc
71
mtbackup
M
anhtuan1066
  • Question Question
Đọc số thành chữ có phần thập phân
Trả lời
12
Đọc
8K
caocat
C
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
96
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
149
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
85
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD
    • Cười
Trả lời
0
Đọc
103
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
83
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
4
Đọc
83
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
3
Đọc
104
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++
    • Thích
Trả lời
0
Đọc
120
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
236
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác. (1 người xem)
Trả lời
1
Đọc
85
BuiQuangThuan
B
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom