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
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.
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
227
SA_DQ
SA_DQ
N
Xin giúp e cách lọc dữ liệu bị trùng (1 người xem)
Trả lời
3
Đọc
131
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
95
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • 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 (1 người xem)
    • 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 (1 người xem)
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 (1 người xem)
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
83
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