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
Mã: 
For i = 2 To UBound(Darr)
    If Darr(i, 8) = [COLOR=#ff0000]"NXLQ" [/COLOR]Then
        k = k + 1
        For j = 1 To 6
            [COLOR=#ff0000]arrNX(k, j)[/COLOR] = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j        
        If Not Dic.Exists([COLOR=#ff0000]arrNX(k, 1)[/COLOR]) Then Dic.Add [COLOR=#ff0000]arrNX(k, 1)[/COLOR], ""
    End If

Mã: 
For i = 2 To [COLOR=#ff0000]nDO[/COLOR]
    If Dic.Exists([COLOR=#ff0000]arrDO(i, 1))[/COLOR] Then
        If Not Dic_Dic.Exists([COLOR=#ff0000]arrDO(i, 1)[/COLOR]) Then
            Dic_Dic.Add [COLOR=#ff0000]arrDO(i, 1)[/COLOR], ""
            k = k + 1
            For j = 1 To 6
                arrNX_DO(k, j) = [COLOR=#ff0000]arrDO(i, j)[/COLOR]
bạn phải đảo ngược lại chạy lấy dữ liệu của DORU trước để gán vào Dic
cụ thể lệnh màu đỏ cái nào của DO thì thay bằng NX và ngược lại
nhưng các sheet chạy sau sẽ so sánh theo DO không cò so sánh theo NX
 
Upvote 0
HieuCD đã viết:
Mã: 
For i = 2 To UBound(Darr)
    If Darr(i, 8) = [COLOR=#ff0000]"NXLQ" [/COLOR]Then
        k = k + 1
        For j = 1 To 6
            [COLOR=#ff0000]arrNX(k, j)[/COLOR] = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j        
        If Not Dic.Exists([COLOR=#ff0000]arrNX(k, 1)[/COLOR]) Then Dic.Add [COLOR=#ff0000]arrNX(k, 1)[/COLOR], ""
    End If

Mã: 
For i = 2 To [COLOR=#ff0000]nDO[/COLOR]
    If Dic.Exists([COLOR=#ff0000]arrDO(i, 1))[/COLOR] Then
        If Not Dic_Dic.Exists([COLOR=#ff0000]arrDO(i, 1)[/COLOR]) Then
            Dic_Dic.Add [COLOR=#ff0000]arrDO(i, 1)[/COLOR], ""
            k = k + 1
            For j = 1 To 6
                arrNX_DO(k, j) = [COLOR=#ff0000]arrDO(i, j)[/COLOR]
bạn phải đảo ngược lại chạy lấy dữ liệu của DORU trước để gán vào Dic
cụ thể lệnh màu đỏ cái nào của DO thì thay bằng NX và ngược lại
nhưng các sheet chạy sau sẽ so sánh theo DO không cò so sánh theo NX
Nhấp chuột vào đây để mở rộng...

Dạ cảm ơn thông tin của anh, EM thử viết lại code cho từng mục. Nếu ko được, mong nhờ anh giúp đỡ.
 
Upvote 0
HieuCD đã viết:
Mã: 
For i = 2 To UBound(Darr)
    If Darr(i, 8) = [COLOR=#ff0000]"NXLQ" [/COLOR]Then
        k = k + 1
        For j = 1 To 6
            [COLOR=#ff0000]arrNX(k, j)[/COLOR] = Darr(i, Choose(j, 1, 2, 7, 8, 11, 12))
        Next j        
        If Not Dic.Exists([COLOR=#ff0000]arrNX(k, 1)[/COLOR]) Then Dic.Add [COLOR=#ff0000]arrNX(k, 1)[/COLOR], ""
    End If

Mã: 
For i = 2 To [COLOR=#ff0000]nDO[/COLOR]
    If Dic.Exists([COLOR=#ff0000]arrDO(i, 1))[/COLOR] Then
        If Not Dic_Dic.Exists([COLOR=#ff0000]arrDO(i, 1)[/COLOR]) Then
            Dic_Dic.Add [COLOR=#ff0000]arrDO(i, 1)[/COLOR], ""
            k = k + 1
            For j = 1 To 6
                arrNX_DO(k, j) = [COLOR=#ff0000]arrDO(i, j)[/COLOR]
bạn phải đảo ngược lại chạy lấy dữ liệu của DORU trước để gán vào Dic
cụ thể lệnh màu đỏ cái nào của DO thì thay bằng NX và ngược lại
nhưng các sheet chạy sau sẽ so sánh theo DO không cò so sánh theo NX
Nhấp chuột vào đây để mở rộng...


Dear Anh Hiếu
Nếu có thời gian, Nhờ anh chỉ dẫn cho em thêm phần code VBA tổng hợp báo cáo số liệu. (file đính kèm)
Điều kiện tổng hợp em đã ghi chú trong các ô cần tính.
Mong nhận được sự giúp đõ của anh. em xin chân thành cảm ơn
 

File đính kèm

Upvote 0
dinhquang042000 đã viết:
Dear Anh Hiếu
Nếu có thời gian, Nhờ anh chỉ dẫn cho em thêm phần code VBA tổng hợp báo cáo số liệu. (file đính kèm)
Điều kiện tổng hợp em đã ghi chú trong các ô cần tính.
Mong nhận được sự giúp đõ của anh. em xin chân thành cảm ơn
Nhấp chuột vào đây để mở rộng...
các ghi chú mình không thấy, có lẽ Excel2007 của mình gặp cái gì lạ là nó xử hết, bạn nhập diễn giải bình thường rồi gởi lại.
Nếu bạn có nhu cầu tổng hợp thường xuyên thay đổi thì bạn chép toàn bộ code dưới đây vào riêng 1 module, mỗi lần cần làm gì bạn sửa thông tin trong sub Main rồi chạy
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("A1:P" & Sheets("CMS").Range("A2").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 8): ReDim arrSh_Sh(1 To UBound(Darr), 1 To 8)
For j = 1 To 8
    arrSh(1, j) = Darr(1, Choose(j, 2, 3, 10, 11, 12, 15, 16, 1))
    If tmp = 2 Then arrSh_Sh(1, j) = arrSh(1, j)
Next j
k = 1
For i = 2 To UBound(Darr)
    If Darr(i, 12) = sh Then
        k = k + 1
        For j = 1 To 8
            arrSh(k, j) = Darr(i, Choose(j, 2, 3, 10, 11, 12, 15, 16, 1))
        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:H" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 8) = 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 8
                arrSh_Sh(n, j) = arrSh(i, j)
            Next j
        End If
    Next i
    With Sheets(sh_sh)
        .Range("A1:H" & .Range("A65500").End(xlUp).Row).ClearContents
        .Range("A1").Resize(n + 1, 8) = arrSh_Sh
    End With
End If
End Sub
trong đó bạn sửa thông tin trong các lệnh
Call aadArr("NXLQ", "NXLQ - NXLQ")
...
Call aadArr("DORU", "NXLQ - DORU")
Call aadArr("CAPR", "NXLQ - CAPR")
Call aadArr("CXLA", "NXLQ - CXLA")

Call aadArr("NXLQ", "NXLQ - NXLQ")
"NXLQ" là tên sheet chuẩn để so sánh, bạn nhập tên mới vào
"NXLQ - NXLQ" chỉ nhập cho có, code sẽ không chạy cái nầy

Call aadArr("DORU", "NXLQ - DORU")
"DORU" tên sheet lấy dữ liệu trùng với "NXLQ"
cần bao nhiêu sheet thì bạn dùng lệnh call để tạo

nếu việc trích lọc ổn định và thường xuyên thì bạn tạo nhiều module và nhập sẵn các lệnh call giống như cách bạn làm
code nầy chạy chậm hơn một chút nhưng giúp bạn dể thao tác hơn
 
Upvote 0
HieuCD đã viết:
các ghi chú mình không thấy, có lẽ Excel2007 của mình gặp cái gì lạ là nó xử hết, bạn nhập diễn giải bình thường rồi gởi lại.
Nếu bạn có nhu cầu tổng hợp thường xuyên thay đổi thì bạn chép toàn bộ code dưới đây vào riêng 1 module, mỗi lần cần làm gì bạn sửa thông tin trong sub Main rồi chạy
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("A1:P" & Sheets("CMS").Range("A2").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 8): ReDim arrSh_Sh(1 To UBound(Darr), 1 To 8)
For j = 1 To 8
    arrSh(1, j) = Darr(1, Choose(j, 2, 3, 10, 11, 12, 15, 16, 1))
    If tmp = 2 Then arrSh_Sh(1, j) = arrSh(1, j)
Next j
k = 1
For i = 2 To UBound(Darr)
    If Darr(i, 12) = sh Then
        k = k + 1
        For j = 1 To 8
            arrSh(k, j) = Darr(i, Choose(j, 2, 3, 10, 11, 12, 15, 16, 1))
        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:H" & .Range("A65500").End(xlUp).Row).ClearContents
    .Range("A1").Resize(k + 1, 8) = 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 8
                arrSh_Sh(n, j) = arrSh(i, j)
            Next j
        End If
    Next i
    With Sheets(sh_sh)
        .Range("A1:H" & .Range("A65500").End(xlUp).Row).ClearContents
        .Range("A1").Resize(n + 1, 8) = arrSh_Sh
    End With
End If
End Sub
trong đó bạn sửa thông tin trong các lệnh
Call aadArr("NXLQ", "NXLQ - NXLQ")
...
Call aadArr("DORU", "NXLQ - DORU")
Call aadArr("CAPR", "NXLQ - CAPR")
Call aadArr("CXLA", "NXLQ - CXLA")

Call aadArr("NXLQ", "NXLQ - NXLQ")
"NXLQ" là tên sheet chuẩn để so sánh, bạn nhập tên mới vào
"NXLQ - NXLQ" chỉ nhập cho có, code sẽ không chạy cái nầy

Call aadArr("DORU", "NXLQ - DORU")
"DORU" tên sheet lấy dữ liệu trùng với "NXLQ"
cần bao nhiêu sheet thì bạn dùng lệnh call để tạo

nếu việc trích lọc ổn định và thường xuyên thì bạn tạo nhiều module và nhập sẵn các lệnh call giống như cách bạn làm
code nầy chạy chậm hơn một chút nhưng giúp bạn dể thao tác hơn
Nhấp chuột vào đây để mở rộng...


Dear anh hiếu,

Nhờ code của anh hôm trước em đã sửa đc phần lọc lấy dữ liệu.
Giờ em muốn viết thêm 1 code thay cho countif để đếm số conts ở mỗi phương án theo điều kiện (như hình)
Mong anh chỉ dẫn thêm cho em mục này
 

File đính kèm

  • Untitled.jpg
    Untitled.jpg
    37.4 KB · Đọc: 8
  • Untitled.jpg
    Untitled.jpg
    39.8 KB · Đọc: 7
Upvote 0
dinhquang042000 đã viết:
Dear anh hiếu,

Nhờ code của anh hôm trước em đã sửa đc phần lọc lấy dữ liệu.
Giờ em muốn viết thêm 1 code thay cho countif để đếm số conts ở mỗi phương án theo điều kiện (như hình)
Mong anh chỉ dẫn thêm cho em mục này
Nhấp chuột vào đây để mở rộng...
đọc không rỏ lắm có gì bạn chỉnh code lại
Mã: 
Option Explicit
Sub SoCont()
Dim arrNH_Do, arrNX_DO, i As Long, KHA22 As Long, CTL22 As Long
Dim KHA45 As Long, CTL45 As Long, NX22 As Long
With Sheets("NHAR - DORU")
    arrNH_Do = .Range("A2:H" & .Range("A2").End(xlDown).Row)
End With
With Sheets("NXLQ - DORU")
    arrNX_DO = .Range("A2:H" & .Range("A2").End(xlDown).Row)
End With
For i = 2 To UBound(arrNH_Do)
    If arrNH_Do(i, 2) = 2200 Then
        If arrNH_Do(i, 6) = "KHA" Then KHA22 = KHA22 + 1
        If arrNH_Do(i, 6) = "CTL" Then CTL22 = CTL22 + 1
    End If
    If arrNH_Do(i, 2) = 4200 Or arrNH_Do(i, 2) = 4500 Then
        If arrNH_Do(i, 6) = "KHA" Then KHA45 = KHA45 + 1
        If arrNH_Do(i, 6) = "CTL" Then CTL45 = CTL45 + 1
    End If
Next i
For i = 2 To UBound(arrNX_DO)
    If arrNX_DO(i, 2) = 2200 And arrNX_DO(i, 6) = "CTL" Then
        NX22 = NX22 + 1
    End If
Next i
With Sheets("BAOCAO")
    .Range("D10") = CTL22:  .Range("E10") = CTL45
    .Range("D12") = KHA22:  .Range("E12") = KHA45
    .Range("D13") = NX22
End With
End Sub
 
Upvote 0
HieuCD đã viết:
đọc không rỏ lắm có gì bạn chỉnh code lại
Mã: 
Option Explicit
Sub SoCont()
Dim arrNH_Do, arrNX_DO, i As Long, KHA22 As Long, CTL22 As Long
Dim KHA45 As Long, CTL45 As Long, NX22 As Long
With Sheets("NHAR - DORU")
    arrNH_Do = .Range("A2:H" & .Range("A2").End(xlDown).Row)
End With
With Sheets("NXLQ - DORU")
    arrNX_DO = .Range("A2:H" & .Range("A2").End(xlDown).Row)
End With
For i = 2 To UBound(arrNH_Do)
    If arrNH_Do(i, 2) = 2200 Then
        If arrNH_Do(i, 6) = "KHA" Then KHA22 = KHA22 + 1
        If arrNH_Do(i, 6) = "CTL" Then CTL22 = CTL22 + 1
    End If
    If arrNH_Do(i, 2) = 4200 Or arrNH_Do(i, 2) = 4500 Then
        If arrNH_Do(i, 6) = "KHA" Then KHA45 = KHA45 + 1
        If arrNH_Do(i, 6) = "CTL" Then CTL45 = CTL45 + 1
    End If
Next i
For i = 2 To UBound(arrNX_DO)
    If arrNX_DO(i, 2) = 2200 And arrNX_DO(i, 6) = "CTL" Then
        NX22 = NX22 + 1
    End If
Next i
With Sheets("BAOCAO")
    .Range("D10") = CTL22:  .Range("E10") = CTL45
    .Range("D12") = KHA22:  .Range("E12") = KHA45
    .Range("D13") = NX22
End With
End Sub
Nhấp chuột vào đây để mở rộng...

Mong anh giúp em thêm trường hợp này,

Em muốn tổng hợp số liệu từ 2 sheet NhAP và sheet CAP sang sheet CMS. 2 sheet này cùng tiêu đề nền chỉ giữ lại tiêu đề của 1 cái.
Cảm ơn sự giúp đỡ của anh
 

File đính kèm

Upvote 0
dinhquang042000 đã viết:
Mong anh giúp em thêm trường hợp này,

Em muốn tổng hợp số liệu từ 2 sheet NhAP và sheet CAP sang sheet CMS. 2 sheet này cùng tiêu đề nền chỉ giữ lại tiêu đề của 1 cái.
Cảm ơn sự giúp đỡ của anh
Nhấp chuột vào đây để mở rộng...
bạn dùng code
Mã: 
Option Explicit
Sub TonhHopCMS()
Dim LastNhapR As Long, LastCapR As Long
LastNhapR = Sheets("NHAP").Range("A65500").End(xlUp).Row
LastCapR = Sheets("CAP").Range("A65500").End(xlUp).Row
Sheets("CMS").Range("A1:V65500").ClearContents
If LastNhapR > 1 Then
    Sheets("CMS").Range("A1").Resize(LastNhapR, 22) = Sheets("NHAP").Range("A1:V" & LastNhapR).Value
    If LastCapR > 1 Then Sheets("CMS").Range("A" & LastNhapR + 1).Resize(LastCapR - 1, 22) = Sheets("CAP").Range("A2:V" & LastCapR).Value
Else
    If LastCapR > 1 Then Sheets("CMS").Range("A1").Resize(LastCapR, 22) = Sheets("CAP").Range("A1:V" & LastCapR).Value
End If
End Sub
 
Upvote 0
HieuCD đã viết:
bạn dùng code
Mã: 
Option Explicit
Sub TonhHopCMS()
Dim LastNhapR As Long, LastCapR As Long
LastNhapR = Sheets("NHAP").Range("A65500").End(xlUp).Row
LastCapR = Sheets("CAP").Range("A65500").End(xlUp).Row
Sheets("CMS").Range("A1:V65500").ClearContents
If LastNhapR > 1 Then
    Sheets("CMS").Range("A1").Resize(LastNhapR, 22) = Sheets("NHAP").Range("A1:V" & LastNhapR).Value
    If LastCapR > 1 Then Sheets("CMS").Range("A" & LastNhapR + 1).Resize(LastCapR - 1, 22) = Sheets("CAP").Range("A2:V" & LastCapR).Value
Else
    If LastCapR > 1 Then Sheets("CMS").Range("A1").Resize(LastCapR, 22) = Sheets("CAP").Range("A1:V" & LastCapR).Value
End If
End Sub
Nhấp chuột vào đây để mở rộng...

Code hay lắm ạ, Cảm ơn anh thật nhiều
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
longlacda
L
V
Công thức để phân công chuyên môn cho giáo viên (3 người xem)
Trả lời
5
Đọc
262
vietvanyen
V
E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng
Trả lời
12
Đọc
230
Phan Thế Hiệp
Phan Thế Hiệp
G
AddIn convert ngày dương lịch sang âm lịch và ngược lại + đọc ngày tháng
Trả lời
20
Đọc
10K
du trung kien
D
8
Hàm trong excel
Trả lời
3
Đọc
61
Hoàng Tuấn 868
H
N
Chuyển giờ công từ bảng công vào bảng tính
Trả lời
16
Đọc
291
ngouyen1505
N
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
7
Đọc
656
nguyendang95
N
T
Tìm số hóa đơn trong chuỗi
Trả lời
8
Đọc
353
tranhungdao12a3
T
Nga1852k
lỗi excel không chèn được dòng và không xóa được dòng
Trả lời
2
Đọc
134
Nga1852k
Nga1852k
D
  • Question Question
xin các cao thủ trợ giúp , hoặc nhận làm code có trả phí ạ
Trả lời
14
Đọc
1K
tung1423
tung1423
D
xin hỏi về lỗi mô đun ẩn.
Trả lời
3
Đọc
144
ongke0711
ongke0711
H
Xin anh chị hướng dẫn công thức excel ạ.
Trả lời
9
Đọc
288
Phan Thế Hiệp
Phan Thế Hiệp
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
381
Đọc
44K
tuanktt3
T
M
Add-in Excel kết nối cơ sở dữ liệu
Trả lời
1
Đọc
111
ptm0412
ptm0412
Đ
tách dữ liệu từ một dòng thành hai dòng
Trả lời
2
Đọc
154
Phuocam
Phuocam
longhuy
Lỗi error 20728: F (1 người xem)
Trả lời
0
Đọc
77
longhuy
longhuy
H
Trang tính chỉ hiển thị vùng có dữ liệu
Trả lời
7
Đọc
607
vinhkm6
vinhkm6
mrjun80
Có hàm nào đếm tổng các số nằm trong 1 ô không mọi người
Trả lời
12
Đọc
499
Phan Thế Hiệp
Phan Thế Hiệp
N
Hàm DATEDIF trong Excel 2016
Trả lời
16
Đọc
14K
Phan Thế Hiệp
Phan Thế Hiệp
Tiger Nau
Đánh số thứ tự trên tờ vé số (1 người xem)
Trả lời
6
Đọc
186
ptm0412
ptm0412
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom