Cập nhật giữ liệu không trùng qua các sheet theo điều kiện. (1 người xem)

  • Thread starter Thread starter lhthai
  • Ngày gửi Ngày gửi
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)
L

lhthai

Thành viên thường trực
Tham gia
1/9/07
Bài viết
309
Được thích
27
Mình muốn cập nhật những dữ liệu không trùng tại sheet DMPP sang 3 sheet NVY, sheet AVP, sheet IV theo điều kiện như sau
Tại sheet DMPP
Nếu Left(B,2)="IV" thì trả về sheet IV
Nếu Left(B,2)="AV" hoặc "VP" thì trả về sheet AVP
Còn lại thì trả về sheet NVY.
Hiện tại code đang trả tất cả dữ liệu về sheet NVY
Mã: 
Private Sub CommandButton1_Click()
Dim Dic As Object, sArr(), dArr(), I As Long, k As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet2
        sArr = .Range(.[B5], .[B5].End(xlDown)).Resize(, 3).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
            If Not Dic.exists(Tem) Then
                Dic.Add Tem, Empty
            End If
        Next I
    End With
 With Sheet3
        sArr = .Range(.[B5], .[B5].End(xlDown)).Resize(, 3).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
            If Not Dic.exists(Tem) Then
                Dic.Add Tem, Empty
            End If
        Next I
    End With
 With Sheet4
        sArr = .Range(.[B5], .[B5].End(xlDown)).Resize(, 3).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
            If Not Dic.exists(Tem) Then
                Dic.Add Tem, Empty
            End If
        Next I
    End With
With Sheet5
    sArr = .Range(.[B9], .[B9].End(xlDown)).Resize(, 3).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
        If Not Dic.exists(Tem) Then
            k = k + 1
            Dic.Add Tem, Empty
            dArr(k, 1) = sArr(I, 1)
            dArr(k, 2) = sArr(I, 2)
            dArr(k, 3) = sArr(I, 3)
        End If
    Next I
    End With
    With Sheet2
        If k Then
    .[B65536].End(xlUp)(2).Resize(k, 3) = dArr
    Else
      Exit Sub
     End If
    End With
End Sub
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
lhthai đã viết:
Mình muốn cập nhật những dữ liệu không trùng tại sheet DMPP sang 3 sheet NVY, sheet AVP, sheet IV theo điều kiện như sau
Tại sheet DMPP
Nếu Left(B,2)="IV" thì trả về sheet IV
Nếu Left(B,2)="AV" hoặc "VP" thì trả về sheet AVP
Còn lại thì trả về sheet NVY.
Hiện tại code đang trả tất cả dữ liệu về sheet NVY
Nhấp chuột vào đây để mở rộng...

Không trùng là xét theo cột nào? Hay cả 3 cột B,C,D?
Híc!
PHP: 
Public Sub GPE()
Dim Dic As Object, Tem As String, DK As String
Dim sArr(), dArr(), Arr, I As Long, J As Long, K As Long, N As Long
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Array("IV", "AVP", "NVY")
With Sheets("DMPP")
    sArr = .Range(.[B9], .[B9].End(xlDown)).Resize(, 4).Value2
End With
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 3)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, Empty
        If Left(sArr(I, 1), 2) = "IV" Then
            sArr(I, 4) = "IV"
        ElseIf Left(sArr(I, 1), 2) = "AV" Or Left(sArr(I, 1), 2) = "VP" Then
            sArr(I, 4) = "AVP"
        Else
            sArr(I, 4) = "NVY"
        End If
    End If
Next I
For N = 0 To 2
    DK = Arr(N)
    With Sheets(DK)
        K = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 4)
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 4) = DK Then
                K = K + 1
                dArr(K, 1) = K
                For J = 1 To 3
                    dArr(K, J + 1) = sArr(I, J)
                Next J
            End If
        Next I
        .Range("A5:D1000").ClearContents
        If K Then .Range("A5").Resize(K, 4) = dArr
    End With
Next N
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Không trùng là xét theo cột nào? Hay cả 3 cột B,C,D?
Híc!
Nhấp chuột vào đây để mở rộng...
Trường hợp của em xét cả 3 cột B,C,D còn code này nếu cột B9 thay đổi thì code cập nhật ghi đè lên cột B5 của sheet IV luôn.
Còn cái này em không hiểu trong file của em không có Sheets(DK) mà code vẫn chạy.
Cám ơn Anh Rất nhiều.Em sẽ tìm hiểu thêm.
 
Upvote 0
lhthai đã viết:
Trường hợp của em xét cả 3 cột B,C,D còn code này nếu cột B9 thay đổi thì code cập nhật ghi đè lên cột B5 của sheet IV luôn.
Còn cái này em không hiểu trong file của em không có Sheets(DK) mà code vẫn chạy.
Cám ơn Anh Rất nhiều.Em sẽ tìm hiểu thêm.
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử đoạn code này nhé:
Mã: 
Option Explicit


Public Sub LocKhongTrung()
Dim i As Long, j As Long, LrM As Long, LrC As Long, d As Long, dem As Long
Dim sArr(), Tmp(), Tg()
Dim DK As String, HaiKTDau, DK1 As String, DK2 As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")


Application.ScreenUpdating = False
LrM = Sheet5.Range("B" & Rows.Count).End(xlUp).Row
sArr = Sheet5.Range("B9:D" & LrM)
ReDim Tmp(1 To UBound(sArr), 1 To 3)


For i = 1 To UBound(sArr)
        DK = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
    If Not Dic.Exists(DK) Then
        d = d + 1
        Dic.Add DK, d
        Tmp(d, 1) = sArr(i, 1): Tmp(d, 2) = sArr(i, 2): Tmp(d, 3) = sArr(i, 3)
    End If
Next i


For i = 1 To UBound(Tmp)
HaiKTDau = Left(Tmp(i, 1), 2)
DK1 = Tmp(i, 1) & Tmp(i, 2) & Tmp(i, 3)
Select Case HaiKTDau


Case Is = "IV"
    Sheet4.Activate
    LrC = Sheet4.Range("B" & Rows.Count).End(xlUp).Row
    Tg = Sheet4.Range("B5:D" & LrC)
    dem = 0
    For j = 1 To UBound(Tg)
        DK2 = Tg(j, 1) & Tg(j, 2) & Tg(j, 3)
            If DK2 = DK1 Then
                dem = dem + 1
            End If
    Next j
            If dem = 0 Then
                Sheet4.Range("B" & LrC + 1) = Tmp(i, 1)
                Sheet4.Range("C" & LrC + 1) = Tmp(i, 2)
                Sheet4.Range("D" & LrC + 1) = Tmp(i, 3)
            End If
     
Case Is = "AV"
    Sheet3.Activate
    LrC = Sheet3.Range("B" & Rows.Count).End(xlUp).Row
    Tg = Sheet3.Range("B5:D" & LrC)
    dem = 0
    For j = 1 To UBound(Tg)
        DK2 = Tg(j, 1) & Tg(j, 2) & Tg(j, 3)
            If DK2 = DK1 Then
                dem = dem + 1
            End If
    Next j
            If dem = 0 Then
                Sheet3.Range("B" & LrC + 1) = Tmp(i, 1)
                Sheet3.Range("C" & LrC + 1) = Tmp(i, 2)
                Sheet3.Range("D" & LrC + 1) = Tmp(i, 3)
            End If
    
Case Is = "VP"
    Sheet3.Activate
    LrC = Sheet3.Range("B" & Rows.Count).End(xlUp).Row
    Tg = Sheet3.Range("B5:D" & LrC)
    dem = 0
    For j = 1 To UBound(Tg)
        DK2 = Tg(j, 1) & Tg(j, 2) & Tg(j, 3)
            If DK2 = DK1 Then
                dem = dem + 1
            End If
    Next j
            If dem = 0 Then
                Sheet3.Range("B" & LrC + 1) = Tmp(i, 1)
                Sheet3.Range("C" & LrC + 1) = Tmp(i, 2)
                Sheet3.Range("D" & LrC + 1) = Tmp(i, 3)
            End If
Case Else
    Sheet2.Activate
    LrC = Sheet2.Range("B" & Rows.Count).End(xlUp).Row
    Tg = Sheet2.Range("B5:D" & LrC)
    dem = 0
    For j = 1 To UBound(Tg)
        DK2 = Tg(j, 1) & Tg(j, 2) & Tg(j, 3)
            If DK2 = DK1 Then
                dem = dem + 1
            End If
    Next j
            If dem = 0 Then
                Sheet2.Range("B" & LrC + 1) = Tmp(i, 1)
                Sheet2.Range("C" & LrC + 1) = Tmp(i, 2)
                Sheet2.Range("D" & LrC + 1) = Tmp(i, 3)
            End If
    
End Select


Next i
Sheet5.Activate
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
lhthai đã viết:
Trường hợp của em xét cả 3 cột B,C,D còn code này nếu cột B9 thay đổi thì code cập nhật ghi đè lên cột B5 của sheet IV luôn.
Còn cái này em không hiểu trong file của em không có Sheets(DK) mà code vẫn chạy.
Cám ơn Anh Rất nhiều.Em sẽ tìm hiểu thêm.
Nhấp chuột vào đây để mở rộng...

Là do bạn giải thích yêu cầu không rõ, cập nhật thêm vào, không trùng, giữ nguyên dữ liệu hiện có trong các sheet con ... thêm vào code của tôi vài dòng là xong.
PHP: 
Public Sub GPE()
Dim Dic As Object, Tem As String, DK As String, R As Long, STT As Long
Dim sArr(), dArr(), tArr(), Arr, I As Long, J As Long, K As Long, N As Long
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Array("IV", "AVP", "NVY")
With Sheets("DMPP")
    sArr = .Range(.[B9], .[B9].End(xlDown)).Resize(, 4).Value2
End With
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 3)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, I
        If Left(sArr(I, 1), 2) = "IV" Then
            sArr(I, 4) = "IV"
        ElseIf Left(sArr(I, 1), 2) = "AV" Or Left(sArr(I, 1), 2) = "VP" Then
            sArr(I, 4) = "AVP"
        Else
            sArr(I, 4) = "NVY"
        End If
    End If
Next I
For N = 0 To 2
    DK = Arr(N)
    With Sheets(DK)
        R = .Range("A65536").End(xlUp).Row
        STT = .Range("A" & R).Value
        tArr = .Range("A5:D" & R).Value
        For I = 1 To UBound(tArr, 1)
            Tem = tArr(I, 2) & "#" & tArr(I, 3) & "#" & tArr(I, 4)
            If Dic.Exists(Tem) Then sArr(Dic.Item(Tem), 4) = Empty
        Next I
        K = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 4)
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 4) = DK Then
                K = K + 1
                STT = STT + 1
                dArr(K, 1) = STT
                For J = 1 To 3
                    dArr(K, J + 1) = sArr(I, J)
                Next J
            End If
        Next I
        If K Then .Range("A" & R + 1).Resize(K, 4) = dArr
    End With
Next N
Set Dic = Nothing
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
lhthai đã viết:
Mình muốn cập nhật những dữ liệu không trùng tại sheet DMPP sang 3 sheet NVY, sheet AVP, sheet IV theo điều kiện như sau
Tại sheet DMPP
Nếu Left(B,2)="IV" thì trả về sheet IV
Nếu Left(B,2)="AV" hoặc "VP" thì trả về sheet AVP
Còn lại thì trả về sheet NVY.
Hiện tại code đang trả tất cả dữ liệu về sheet NVY
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử code chưa , kết quả thế nào rồi? Không thấy bạn hồi âm qua!
 
Upvote 0
lhthai đã viết:
Mới chạy thử thấy rất đúng.
Cám ơn bạn nhiều
Nhấp chuột vào đây để mở rộng...
Mình mới rút ngắn code thêm chút bạn copy về thay đoạn lúc trước:
Mã: 
Option Explicit

Dim i As Long, j As Long, LrM As Long, LrC As Long, d As Long, dem As Long
Dim sArr(), Tmp(), Tg()
Dim DK As String, HaiKTDau, DK1 As String, DK2 As String, NameSh As String

Public Sub LocKhongTrungNew()
Dim d As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
        LrM = Sheet5.Range("B" & Rows.Count).End(xlUp).Row
        sArr = Sheet5.Range("B9:D" & LrM): ReDim Tmp(1 To UBound(sArr), 1 To 3)
For i = 1 To UBound(sArr)
        DK = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
    If Not Dic.Exists(DK) Then
        d = d + 1: Dic.Add DK, d
        Tmp(d, 1) = sArr(i, 1): Tmp(d, 2) = sArr(i, 2): Tmp(d, 3) = sArr(i, 3)
    End If
Next i
For i = 1 To UBound(Tmp)
    HaiKTDau = Left(Tmp(i, 1), 2): DK1 = Tmp(i, 1) & Tmp(i, 2) & Tmp(i, 3)
    If HaiKTDau = "IV" Then
        NameSh = "IV": Call CHUOT0106
    ElseIf HaiKTDau = "AV" Or HaiKTDau = "[B][COLOR=#ff0000]VP[/COLOR][/B]" Then
        NameSh = "AVP": Call CHUOT0106
    Else
        NameSh = "NVY": Call CHUOT0106
    End If
Next i
Sheet5.Activate: Application.ScreenUpdating = True
End Sub
'----------------------------------------------------------------------------
Public Sub CHUOT0106()
    Sheets(NameSh).Activate
    LrC = Sheets(NameSh).Range("B" & Rows.Count).End(xlUp).Row
    Tg = Sheets(NameSh).Range("B5:D" & LrC).Value
    dem = 0
    For j = 1 To UBound(Tg)
        DK2 = Tg(j, 1) & Tg(j, 2) & Tg(j, 3)
            If DK2 = DK1 Then dem = dem + 1
    Next j
            If dem = 0 Then
                Sheets(NameSh).Range("B" & LrC + 1) = Tmp(i, 1)
                Sheets(NameSh).Range("C" & LrC + 1) = Tmp(i, 2)
                Sheets(NameSh).Range("D" & LrC + 1) = Tmp(i, 3)
            End If
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Tôi vừa sửa lại code và đính kèm file trên bài #5.
 
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

GPE-Trợ Lý
[GPE] TALK SHOW CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365 (1 người xem)
Trả lời
1
Đọc
48
VetMini
V
X
add-in báo lỗi mỗi khi mở file (1 người xem)
Trả lời
4
Đọc
84
Xike20009x
X
N
e cần hỗ trợ code vba từ các a chị trên đây ạ.
Trả lời
0
Đọc
35
nguyendinhanh10496@gmail.
N
Nguyễn Duy Tuân
Add-In A-Tools - Truy vấn (lọc), soạn thảo và quản trị dữ liệu Excel qua mạng (1 người xem)
    • Thích
32 33 34
Trả lời
670
Đọc
265K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
43
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
NguyenBaChien
Nhờ tách lấy số và tính tổng có điều kiện của dãy số (1 người xem)
Trả lời
6
Đọc
142
bebo021999
B
L
[Xin giúp] Cách copy công thức từ bảng tham chiếu vào một ô (2 người xem)
Trả lời
4
Đọc
107
bebo021999
B
K
cố định, không thay đổi kích thước, ( fit) độ rộng dòng, cột
Trả lời
5
Đọc
78
HeSanbi
HeSanbi
E
Tính tổng số tiền còn lại theo điều kiện
Trả lời
4
Đọc
43
Em khong biet
E
T
  • Question Question
Lọc dữ liệu có nhiều điều kiện
Trả lời
4
Đọc
162
tt_kimbai
T
dung1983
Hỏi về import - Table/ XML cho bảng, trang có chứa JS (1 người xem)
Trả lời
2
Đọc
105
HeSanbi
HeSanbi
hoangluongvinh
Cách nhặt các dữ liệu bị trùng của 1 đối tượng
Trả lời
12
Đọc
222
vantuongk4
V
HeSanbi
  • Question Question
VBA nâng cao: Nhúng tập tin vào trang tính hoặc trích xuất chúng nhanh chóng
    • Thích
    • Cảm ơn
Trả lời
1
Đọc
251
HeSanbi
HeSanbi
H
xin mọi người giúp em làm tròn với ạ
Trả lời
5
Đọc
116
vietduc147258
V
N
  • Question Question
Cách viết tiếng việt có dấu trong msgbox,....... Hoàn toàn mới (2 người xem)
    • Thích
2
Trả lời
35
Đọc
5K
ligktit
L
longhungvnpost
cả nhà giúp e tạo ô tìm kiếm gợi ý trong danh sách nhé (1 người xem)
Trả lời
3
Đọc
123
longhungvnpost
longhungvnpost
S
Cố định độ rộng/ cao của cột/hàng?
Trả lời
12
Đọc
17K
khanhnth02
K
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
329
Đọc
26K
tt_kimbai
T
HeSanbi
  • Đã giải quyết
VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
51
Đọc
15K
HeSanbi
HeSanbi
Manhhung90
Mail merge in ấn theo từng trang mong muốn.
Trả lời
1
Đọc
121
Hoàng Tuấn 868
H
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