Đếm không trùng có điều kiệu

Liên hệ QC
M

mitdacdtd

Thành viên hoạt động
Tham gia
14/10/17
Bài viết
150
Được thích
23
Giới tính
Nam
Chào anh em.
Hiện mình có file báo cáo cần đếm dữ liệu không trùng theo điều kiện Ca làm việc và ngày làm việc gồm 2 phần : Dữ liệu 1 theo báo cáo 1; Dữ liệu 2 theo báo cáo 2 và Báo cáo nhân sự từ 2 sheet dữ liệu 1 và 2.
Thân nhờ anh em giúp phần VBA với nhé.
Cảm ơn anh em nhiều. Chúc mọi người cuối tuần vui vẻ.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
mitdacdtd đã viết:
Chào anh em.
Hiện mình có file báo cáo cần đếm dữ liệu không trùng theo điều kiện Ca làm việc và ngày làm việc gồm 2 phần : Dữ liệu 1 theo báo cáo 1; Dữ liệu 2 theo báo cáo 2 và Báo cáo nhân sự từ 2 sheet dữ liệu 1 và 2.
Thân nhờ anh em giúp phần VBA với nhé.
Cảm ơn anh em nhiều. Chúc mọi người cuối tuần vui vẻ.
Nhấp chuột vào đây để mở rộng...
sheet báo cáo 2, cột b, sửa b thành a nhé bạn
Mã: 
Option Explicit

Sub TongHop()
Dim DL1, DL2
Dim BC1, BC2, BCNS
Dim Mang
Dim DicM As Object
Dim i, k, t
DL1 = Sheet1.Range("A1").CurrentRegion
DL2 = Sheet3.Range("A1").CurrentRegion
BC1 = Sheet2.Range("A1").CurrentRegion
BC2 = Sheet4.Range("A1").CurrentRegion
Set DicM = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    k = 0
    If DL1(i, 4) <> "" Then
        DicM(DL1(i, 4)) = DL1(i, 2)
        k = k + 1
    End If
    If DL1(i, 5) <> "" Then
        DicM(DL1(i, 5)) = DL1(i, 2)
        k = k + 1
    End If
    If DicM.exists(t) = False Then
        DicM(t) = Array(k, DL1(i, 3))
    Else
        Mang = DicM(t)
        Mang(0) = Mang(0) + k
        Mang(1) = Mang(1) + DL1(i, 3)
        DicM(t) = Mang
    End If
Next i
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    DicM(DL2(i, 3)) = DL2(i, 4)
    If DicM.exists(t) = False Then
        DicM(t) = Array(1, DL2(i, 2))
    Else
        Mang = DicM(t)
        Mang(0) = Mang(0) + 1
        Mang(1) = Mang(1) + DL2(i, 2)
        DicM(t) = Mang
    End If
Next i
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.exists(t) = True Then
        BC1(i, 3) = DicM(t)(0)
        BC1(i, 4) = DicM(t)(1)
        DicM.Remove t
    End If
Next i
Sheet2.UsedRange.ClearContents
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.exists(t) = True Then
        BC2(i, 3) = DicM(t)(1)
        BC2(i, 4) = DicM(t)(0)
        DicM.Remove t
    End If
Next i
Sheet4.UsedRange.ClearContents
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1
ReDim BCNS(1 To DicM.Count + 1, 1 To 2)
BCNS(1, 1) = Sheet5.Range("A1")
BCNS(1, 2) = Sheet5.Range("B1")
i = 1
k = 1
For Each t In DicM.keys
    If IsArray(DicM(t)) = False Then
        If Left(DicM(t), 1) = "A" Then
            i = i + 1
            BCNS(i, 1) = t
        Else
            If Left(DicM(t), 1) = "B" Then
                k = k + 1
                BCNS(k, 2) = t
            End If
        End If
    End If
Next t
Sheet5.UsedRange.ClearContents
Sheet5.Range("A1").Resize(UBound(BCNS), UBound(BCNS, 2)) = BCNS
Sheet5.Range("A1").Resize(UBound(BCNS), UBound(BCNS, 2)).Borders.LineStyle = 1
End Sub
 
Upvote 0
CHAOQUAY đã viết:
sheet báo cáo 2, cột b, sửa b thành a nhé bạn
Mã: 
Option Explicit

Sub TongHop()
Dim DL1, DL2
Dim BC1, BC2, BCNS
Dim Mang
Dim DicM As Object
Dim i, k, t
DL1 = Sheet1.Range("A1").CurrentRegion
DL2 = Sheet3.Range("A1").CurrentRegion
BC1 = Sheet2.Range("A1").CurrentRegion
BC2 = Sheet4.Range("A1").CurrentRegion
Set DicM = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    k = 0
    If DL1(i, 4) <> "" Then
        DicM(DL1(i, 4)) = DL1(i, 2)
        k = k + 1
    End If
    If DL1(i, 5) <> "" Then
        DicM(DL1(i, 5)) = DL1(i, 2)
        k = k + 1
    End If
    If DicM.exists(t) = False Then
        DicM(t) = Array(k, DL1(i, 3))
    Else
        Mang = DicM(t)
        Mang(0) = Mang(0) + k
        Mang(1) = Mang(1) + DL1(i, 3)
        DicM(t) = Mang
    End If
Next i
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    DicM(DL2(i, 3)) = DL2(i, 4)
    If DicM.exists(t) = False Then
        DicM(t) = Array(1, DL2(i, 2))
    Else
        Mang = DicM(t)
        Mang(0) = Mang(0) + 1
        Mang(1) = Mang(1) + DL2(i, 2)
        DicM(t) = Mang
    End If
Next i
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.exists(t) = True Then
        BC1(i, 3) = DicM(t)(0)
        BC1(i, 4) = DicM(t)(1)
        DicM.Remove t
    End If
Next i
Sheet2.UsedRange.ClearContents
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.exists(t) = True Then
        BC2(i, 3) = DicM(t)(1)
        BC2(i, 4) = DicM(t)(0)
        DicM.Remove t
    End If
Next i
Sheet4.UsedRange.ClearContents
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1
ReDim BCNS(1 To DicM.Count + 1, 1 To 2)
BCNS(1, 1) = Sheet5.Range("A1")
BCNS(1, 2) = Sheet5.Range("B1")
i = 1
k = 1
For Each t In DicM.keys
    If IsArray(DicM(t)) = False Then
        If Left(DicM(t), 1) = "A" Then
            i = i + 1
            BCNS(i, 1) = t
        Else
            If Left(DicM(t), 1) = "B" Then
                k = k + 1
                BCNS(k, 2) = t
            End If
        End If
    End If
Next t
Sheet5.UsedRange.ClearContents
Sheet5.Range("A1").Resize(UBound(BCNS), UBound(BCNS, 2)) = BCNS
Sheet5.Range("A1").Resize(UBound(BCNS), UBound(BCNS, 2)).Borders.LineStyle = 1
End Sub
Nhấp chuột vào đây để mở rộng...
Xin lỗi bạn file mình viết theo cách bên em nên anh hiểu sai ý:
1. Số máy vận hành : chính là tên máy vận hành chứ không phải tổng số máy vận hành.
2. Như bạn nói B thành A
3. Tổng người đi làm các ngày là đếm và lọc trùng theo điều kiện ngày ( Ví dụ ngày 02/05/2019, tổ A1 có 8 người đi làm)
Anh xem lại giúp em nhé. Cảm ơn anh nhiều.
 
Lần chỉnh sửa cuối:
Upvote 0
Các thầy và anh chị em diễn đàn giúp em với ạ
 
Upvote 0
mitdacdtd đã viết:
Các thầy và anh chị em diễn đàn giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Bạn dùng code này thay thế
Mã: 
Sub A_TongHop()
Dim DL1, DL2, Dong1, Dong2
Dim BC1, BC2
Dim Mang
Dim DicM As Object
Dim NCB, NCA, MayB, MayA
Dim i, j, k, x, z, t
Set DicM = CreateObject("Scripting.Dictionary")
DL1 = Sheet1.Range("A1").CurrentRegion
Dong1 = UBound(DL1)
DL2 = Sheet3.Range("A1").CurrentRegion
Dong2 = UBound(DL2)
ReDim NCB(1 To Dong1)
ReDim MayB(1 To Dong1)
For i = 2 To Dong1
    If DL1(i, 4) <> "" Then
        If DicM.Exists(DL1(i, 4)) = False Then
            k = k + 1
            DicM(DL1(i, 4)) = k
            NCB(k) = DL1(i, 4)
            DL1(i, 4) = k
        Else
            DL1(i, 4) = DicM(DL1(i, 4))
        End If
    End If
    If DL1(i, 5) <> "" Then
        If DicM.Exists(DL1(i, 5)) = False Then
            k = k + 1
            DicM(DL1(i, 5)) = k
            NCB(k) = DL1(i, 5)
            DL1(i, 5) = k
        Else
            DL1(i, 5) = DicM(DL1(i, 5))
        End If
    End If
    If DL1(i, 3) <> "" Then
        MayB(DL1(i, 3)) = DL1(i, 3)
        If x < DL1(i, 3) Then x = DL1(i, 3)
    End If
Next i
ReDim Preserve NCB(1 To k)
ReDim Preserve MayB(1 To x)
DicM.RemoveAll
k = 0
x = 0
ReDim NCA(1 To Dong2)
ReDim MayA(1 To Dong2)
For i = 2 To Dong2
    If DL2(i, 3) <> "" Then
        If DicM.Exists(DL2(i, 3)) = False Then
            k = k + 1
            DicM(DL2(i, 3)) = k
            NCA(k) = DL2(i, 3)
            DL2(i, 3) = k
        Else
            DL2(i, 3) = DicM(DL2(i, 3))
        End If
    End If
    If DL2(i, 2) <> "" Then
        MayA(DL2(i, 2)) = DL2(i, 2)
        If x < DL2(i, 2) Then x = DL2(i, 2)
    End If
Next i
ReDim Preserve NCA(1 To k)
ReDim Preserve MayA(1 To x)
DicM.RemoveAll
k = 0
x = 0
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCB, MayB)
    End If
    Mang = DicM(t)
    If DL1(i, 4) <> "" Then Mang(0)(DL1(i, 4)) = ""
    If DL1(i, 5) <> "" Then Mang(0)(DL1(i, 5)) = ""
    If DL1(i, 3) <> "" Then Mang(1)(DL1(i, 3)) = ""
    DicM(t) = Mang
Next i
BC1 = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.Exists(t) = True Then
        x = Application.Trim(Join(DicM(t)(0)))
        If x = "" Then
            BC1(i, 3) = UBound(NCB)
        Else
            BC1(i, 3) = UBound(NCB)
            For j = 1 To UBound(DicM(t)(0))
                If DicM(t)(0)(j) = "" Then BC1(i, 3) = BC1(i, 3) - 1
            Next j
        End If
        x = Application.Trim(Join(DicM(t)(1)))
        If x = "" Then
            BC1(i, 4) = UBound(MayB)
        Else
            BC1(i, 4) = UBound(MayB)
            For j = 1 To UBound(DicM(t)(1))
                If DicM(t)(1)(j) = "" Then BC1(i, 4) = BC1(i, 4) - 1
            Next j
        End If
    End If
Next i
Sheet2.UsedRange.ClearContents
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
DicM.RemoveAll
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCA, MayA)
    End If
    Mang = DicM(t)
    If DL2(i, 3) <> "" Then Mang(0)(DL2(i, 3)) = ""
    If DL2(i, 2) <> "" Then Mang(1)(DL2(i, 2)) = ""
    DicM(t) = Mang
Next i
BC2 = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.Exists(t) = True Then
        x = Application.Trim(Join(DicM(t)(0)))
        If x = "" Then
            BC2(i, 3) = UBound(NCA)
        Else
            BC2(i, 3) = UBound(NCA)
            For j = 1 To UBound(DicM(t)(0))
                If DicM(t)(0)(j) = "" Then BC2(i, 3) = BC2(i, 3) - 1
            Next j
        End If
        x = Application.Trim(Join(DicM(t)(1)))
        If x = "" Then
            BC2(i, 4) = UBound(MayA)
        Else
            BC2(i, 4) = UBound(MayA)
            For j = 1 To UBound(DicM(t)(1))
                If DicM(t)(1)(j) = "" Then BC2(i, 4) = BC2(i, 4) - 1
            Next j
        End If
    End If
Next i
Sheet4.UsedRange.ClearContents
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1

Sheet5.Range("A2:B1000000").Clear
Sheet5.Range("A2").Resize(UBound(NCA), 1) = Application.Transpose(NCA)
Sheet5.Range("B2").Resize(UBound(NCB), 1) = Application.Transpose(NCB)
Sheet5.Range("A1").CurrentRegion.Borders.LineStyle = 1
End Sub
 
Upvote 0
CHAOQUAY đã viết:
Bạn dùng code này thay thế
Mã: 
Sub A_TongHop()
Dim DL1, DL2, Dong1, Dong2
Dim BC1, BC2
Dim Mang
Dim DicM As Object
Dim NCB, NCA, MayB, MayA
Dim i, j, k, x, z, t
Set DicM = CreateObject("Scripting.Dictionary")
DL1 = Sheet1.Range("A1").CurrentRegion
Dong1 = UBound(DL1)
DL2 = Sheet3.Range("A1").CurrentRegion
Dong2 = UBound(DL2)
ReDim NCB(1 To Dong1)
ReDim MayB(1 To Dong1)
For i = 2 To Dong1
    If DL1(i, 4) <> "" Then
        If DicM.Exists(DL1(i, 4)) = False Then
            k = k + 1
            DicM(DL1(i, 4)) = k
            NCB(k) = DL1(i, 4)
            DL1(i, 4) = k
        Else
            DL1(i, 4) = DicM(DL1(i, 4))
        End If
    End If
    If DL1(i, 5) <> "" Then
        If DicM.Exists(DL1(i, 5)) = False Then
            k = k + 1
            DicM(DL1(i, 5)) = k
            NCB(k) = DL1(i, 5)
            DL1(i, 5) = k
        Else
            DL1(i, 5) = DicM(DL1(i, 5))
        End If
    End If
    If DL1(i, 3) <> "" Then
        MayB(DL1(i, 3)) = DL1(i, 3)
        If x < DL1(i, 3) Then x = DL1(i, 3)
    End If
Next i
ReDim Preserve NCB(1 To k)
ReDim Preserve MayB(1 To x)
DicM.RemoveAll
k = 0
x = 0
ReDim NCA(1 To Dong2)
ReDim MayA(1 To Dong2)
For i = 2 To Dong2
    If DL2(i, 3) <> "" Then
        If DicM.Exists(DL2(i, 3)) = False Then
            k = k + 1
            DicM(DL2(i, 3)) = k
            NCA(k) = DL2(i, 3)
            DL2(i, 3) = k
        Else
            DL2(i, 3) = DicM(DL2(i, 3))
        End If
    End If
    If DL2(i, 2) <> "" Then
        MayA(DL2(i, 2)) = DL2(i, 2)
        If x < DL2(i, 2) Then x = DL2(i, 2)
    End If
Next i
ReDim Preserve NCA(1 To k)
ReDim Preserve MayA(1 To x)
DicM.RemoveAll
k = 0
x = 0
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCB, MayB)
    End If
    Mang = DicM(t)
    If DL1(i, 4) <> "" Then Mang(0)(DL1(i, 4)) = ""
    If DL1(i, 5) <> "" Then Mang(0)(DL1(i, 5)) = ""
    If DL1(i, 3) <> "" Then Mang(1)(DL1(i, 3)) = ""
    DicM(t) = Mang
Next i
BC1 = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.Exists(t) = True Then
        x = Application.Trim(Join(DicM(t)(0)))
        If x = "" Then
            BC1(i, 3) = UBound(NCB)
        Else
            BC1(i, 3) = UBound(NCB)
            For j = 1 To UBound(DicM(t)(0))
                If DicM(t)(0)(j) = "" Then BC1(i, 3) = BC1(i, 3) - 1
            Next j
        End If
        x = Application.Trim(Join(DicM(t)(1)))
        If x = "" Then
            BC1(i, 4) = UBound(MayB)
        Else
            BC1(i, 4) = UBound(MayB)
            For j = 1 To UBound(DicM(t)(1))
                If DicM(t)(1)(j) = "" Then BC1(i, 4) = BC1(i, 4) - 1
            Next j
        End If
    End If
Next i
Sheet2.UsedRange.ClearContents
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
DicM.RemoveAll
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCA, MayA)
    End If
    Mang = DicM(t)
    If DL2(i, 3) <> "" Then Mang(0)(DL2(i, 3)) = ""
    If DL2(i, 2) <> "" Then Mang(1)(DL2(i, 2)) = ""
    DicM(t) = Mang
Next i
BC2 = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.Exists(t) = True Then
        x = Application.Trim(Join(DicM(t)(0)))
        If x = "" Then
            BC2(i, 3) = UBound(NCA)
        Else
            BC2(i, 3) = UBound(NCA)
            For j = 1 To UBound(DicM(t)(0))
                If DicM(t)(0)(j) = "" Then BC2(i, 3) = BC2(i, 3) - 1
            Next j
        End If
        x = Application.Trim(Join(DicM(t)(1)))
        If x = "" Then
            BC2(i, 4) = UBound(MayA)
        Else
            BC2(i, 4) = UBound(MayA)
            For j = 1 To UBound(DicM(t)(1))
                If DicM(t)(1)(j) = "" Then BC2(i, 4) = BC2(i, 4) - 1
            Next j
        End If
    End If
Next i
Sheet4.UsedRange.ClearContents
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1

Sheet5.Range("A2:B1000000").Clear
Sheet5.Range("A2").Resize(UBound(NCA), 1) = Application.Transpose(NCA)
Sheet5.Range("B2").Resize(UBound(NCB), 1) = Application.Transpose(NCB)
Sheet5.Range("A1").CurrentRegion.Borders.LineStyle = 1
End Sub
Nhấp chuột vào đây để mở rộng...
Em có đưa code vào mà kết quả ra chưa đúng theo phần em thử thủ công, anh xem lại giúp em với nhé.
Em cảm ơn anh nhiều
 

File đính kèm

Upvote 0
mitdacdtd đã viết:
Em có đưa code vào mà kết quả ra chưa đúng theo phần em thử thủ công, anh xem lại giúp em với nhé.
Em cảm ơn anh nhiều
Nhấp chuột vào đây để mở rộng...
Gửi bạn cả file & code.
code hơi thừa nhưng kết quả đat yêu cầu
Mã: 
Option Explicit

Sub TongHop()
Dim DL1, DL2, Dong1, Dong2
Dim BC1, BC2
Dim Mang
Dim DicM As Object
Dim NCB, NCA, MayB, MayA
Dim i, j, k, x, z, t
Set DicM = CreateObject("Scripting.Dictionary")
DL1 = Sheet1.Range("A1").CurrentRegion
Dong1 = UBound(DL1)
DL2 = Sheet3.Range("A1").CurrentRegion
Dong2 = UBound(DL2)
ReDim NCB(1 To Dong1)
ReDim MayB(1 To 2, 1 To Dong1)
For i = 2 To Dong1
    If DL1(i, 4) <> "" Then
        If DicM.Exists(DL1(i, 4)) = False Then
            k = k + 1
            DicM(DL1(i, 4)) = k
            NCB(k) = DL1(i, 4)
            DL1(i, 4) = k
        Else
            DL1(i, 4) = DicM(DL1(i, 4))
        End If
    End If
    If DL1(i, 5) <> "" Then
        If DicM.Exists(DL1(i, 5)) = False Then
            k = k + 1
            DicM(DL1(i, 5)) = k
            NCB(k) = DL1(i, 5)
            DL1(i, 5) = k
        Else
            DL1(i, 5) = DicM(DL1(i, 5))
        End If
    End If
    If DL1(i, 3) <> "" Then
        MayB(1, DL1(i, 3)) = DL1(i, 3)
        MayB(2, DL1(i, 3)) = DL1(i, 3)
        If x < DL1(i, 3) Then x = DL1(i, 3)
    End If
Next i
ReDim Preserve NCB(1 To k)
ReDim Preserve MayB(1 To 2, 1 To x)
DicM.RemoveAll
k = 0
x = 0
ReDim NCA(1 To Dong2)
ReDim MayA(1 To 2, 1 To Dong2)
For i = 2 To Dong2
    If DL2(i, 3) <> "" Then
        If DicM.Exists(DL2(i, 3)) = False Then
            k = k + 1
            DicM(DL2(i, 3)) = k
            NCA(k) = DL2(i, 3)
            DL2(i, 3) = k
        Else
            DL2(i, 3) = DicM(DL2(i, 3))
        End If
    End If
    If DL2(i, 2) <> "" Then
        MayA(1, DL2(i, 2)) = DL2(i, 2)
        MayA(2, DL2(i, 2)) = DL2(i, 2)
        If x < DL2(i, 2) Then x = DL2(i, 2)
    End If
Next i
ReDim Preserve NCA(1 To k)
ReDim Preserve MayA(1 To 2, 1 To x)
DicM.RemoveAll
k = 0
x = 0
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCB, MayB)
    End If
    Mang = DicM(t)
    If DL1(i, 4) <> "" Then Mang(0)(DL1(i, 4)) = ""
    If DL1(i, 5) <> "" Then Mang(0)(DL1(i, 5)) = ""
    If DL1(i, 3) <> "" Then Mang(1)(1, (DL1(i, 3))) = ""
    DicM(t) = Mang
Next i
BC1 = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(BC1)
    For j = 3 To UBound(BC1, 2)
        BC1(i, j) = ""
    Next j
Next i
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.Exists(t) = True Then
        Mang = DicM(t)(0)
        k = 0
        For j = 1 To UBound(Mang)
            If Mang(j) = "" Then k = k + 1
        Next j
        BC1(i, 3) = k
        Mang = DicM(t)(1)
        k = 0
        For j = 1 To UBound(Mang, 2)
            If Mang(1, j) = "" And Mang(2, j) <> "" Then k = k + 1
        Next j
        BC1(i, 4) = k
    End If
Next i
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Clear
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
DicM.RemoveAll
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCA, MayA)
    End If
    Mang = DicM(t)
    If DL2(i, 3) <> "" Then Mang(0)(DL2(i, 3)) = ""
    If DL2(i, 2) <> "" Then Mang(1)(1, (DL2(i, 2))) = ""
    DicM(t) = Mang
Next i
BC2 = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(BC2)
    For j = 3 To UBound(BC2, 2)
        BC2(i, j) = ""
    Next j
Next i
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.Exists(t) = True Then
        Mang = DicM(t)(0)
        k = 0
        For j = 1 To UBound(Mang)
            If Mang(j) = "" Then k = k + 1
        Next j
        BC2(i, 3) = k
        Mang = DicM(t)(1)
        k = 0
        For j = 1 To UBound(Mang, 2)
            If Mang(1, j) = "" And Mang(2, j) <> "" Then k = k + 1
        Next j
        BC2(i, 4) = k
    End If
Next i
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Clear
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1

Sheet5.Range("A2:B1000000").Clear
Sheet5.Range("A2").Resize(UBound(NCA), 1) = Application.Transpose(NCA)
Sheet5.Range("B2").Resize(UBound(NCB), 1) = Application.Transpose(NCB)
Sheet5.Range("A1").CurrentRegion.Borders.LineStyle = 1
End Sub
 

File đính kèm

Upvote 0
CHAOQUAY đã viết:
Gửi bạn cả file & code.
code hơi thừa nhưng kết quả đat yêu cầu
Mã: 
Option Explicit

Sub TongHop()
Dim DL1, DL2, Dong1, Dong2
Dim BC1, BC2
Dim Mang
Dim DicM As Object
Dim NCB, NCA, MayB, MayA
Dim i, j, k, x, z, t
Set DicM = CreateObject("Scripting.Dictionary")
DL1 = Sheet1.Range("A1").CurrentRegion
Dong1 = UBound(DL1)
DL2 = Sheet3.Range("A1").CurrentRegion
Dong2 = UBound(DL2)
ReDim NCB(1 To Dong1)
ReDim MayB(1 To 2, 1 To Dong1)
For i = 2 To Dong1
    If DL1(i, 4) <> "" Then
        If DicM.Exists(DL1(i, 4)) = False Then
            k = k + 1
            DicM(DL1(i, 4)) = k
            NCB(k) = DL1(i, 4)
            DL1(i, 4) = k
        Else
            DL1(i, 4) = DicM(DL1(i, 4))
        End If
    End If
    If DL1(i, 5) <> "" Then
        If DicM.Exists(DL1(i, 5)) = False Then
            k = k + 1
            DicM(DL1(i, 5)) = k
            NCB(k) = DL1(i, 5)
            DL1(i, 5) = k
        Else
            DL1(i, 5) = DicM(DL1(i, 5))
        End If
    End If
    If DL1(i, 3) <> "" Then
        MayB(1, DL1(i, 3)) = DL1(i, 3)
        MayB(2, DL1(i, 3)) = DL1(i, 3)
        If x < DL1(i, 3) Then x = DL1(i, 3)
    End If
Next i
ReDim Preserve NCB(1 To k)
ReDim Preserve MayB(1 To 2, 1 To x)
DicM.RemoveAll
k = 0
x = 0
ReDim NCA(1 To Dong2)
ReDim MayA(1 To 2, 1 To Dong2)
For i = 2 To Dong2
    If DL2(i, 3) <> "" Then
        If DicM.Exists(DL2(i, 3)) = False Then
            k = k + 1
            DicM(DL2(i, 3)) = k
            NCA(k) = DL2(i, 3)
            DL2(i, 3) = k
        Else
            DL2(i, 3) = DicM(DL2(i, 3))
        End If
    End If
    If DL2(i, 2) <> "" Then
        MayA(1, DL2(i, 2)) = DL2(i, 2)
        MayA(2, DL2(i, 2)) = DL2(i, 2)
        If x < DL2(i, 2) Then x = DL2(i, 2)
    End If
Next i
ReDim Preserve NCA(1 To k)
ReDim Preserve MayA(1 To 2, 1 To x)
DicM.RemoveAll
k = 0
x = 0
For i = 2 To UBound(DL1)
    t = DL1(i, 1) & "_" & DL1(i, 2)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCB, MayB)
    End If
    Mang = DicM(t)
    If DL1(i, 4) <> "" Then Mang(0)(DL1(i, 4)) = ""
    If DL1(i, 5) <> "" Then Mang(0)(DL1(i, 5)) = ""
    If DL1(i, 3) <> "" Then Mang(1)(1, (DL1(i, 3))) = ""
    DicM(t) = Mang
Next i
BC1 = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(BC1)
    For j = 3 To UBound(BC1, 2)
        BC1(i, j) = ""
    Next j
Next i
For i = 2 To UBound(BC1)
    t = BC1(i, 1) & "_" & BC1(i, 2)
    If DicM.Exists(t) = True Then
        Mang = DicM(t)(0)
        k = 0
        For j = 1 To UBound(Mang)
            If Mang(j) = "" Then k = k + 1
        Next j
        BC1(i, 3) = k
        Mang = DicM(t)(1)
        k = 0
        For j = 1 To UBound(Mang, 2)
            If Mang(1, j) = "" And Mang(2, j) <> "" Then k = k + 1
        Next j
        BC1(i, 4) = k
    End If
Next i
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Clear
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)) = BC1
Sheet2.Range("A1").Resize(UBound(BC1), UBound(BC1, 2)).Borders.LineStyle = 1
DicM.RemoveAll
For i = 2 To UBound(DL2)
    t = DL2(i, 1) & "_" & DL2(i, 4)
    If DicM.Exists(t) = False Then
        DicM(t) = Array(NCA, MayA)
    End If
    Mang = DicM(t)
    If DL2(i, 3) <> "" Then Mang(0)(DL2(i, 3)) = ""
    If DL2(i, 2) <> "" Then Mang(1)(1, (DL2(i, 2))) = ""
    DicM(t) = Mang
Next i
BC2 = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(BC2)
    For j = 3 To UBound(BC2, 2)
        BC2(i, j) = ""
    Next j
Next i
For i = 2 To UBound(BC2)
    t = BC2(i, 1) & "_" & BC2(i, 2)
    If DicM.Exists(t) = True Then
        Mang = DicM(t)(0)
        k = 0
        For j = 1 To UBound(Mang)
            If Mang(j) = "" Then k = k + 1
        Next j
        BC2(i, 3) = k
        Mang = DicM(t)(1)
        k = 0
        For j = 1 To UBound(Mang, 2)
            If Mang(1, j) = "" And Mang(2, j) <> "" Then k = k + 1
        Next j
        BC2(i, 4) = k
    End If
Next i
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Clear
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)) = BC2
Sheet4.Range("A1").Resize(UBound(BC2), UBound(BC1, 2)).Borders.LineStyle = 1

Sheet5.Range("A2:B1000000").Clear
Sheet5.Range("A2").Resize(UBound(NCA), 1) = Application.Transpose(NCA)
Sheet5.Range("B2").Resize(UBound(NCB), 1) = Application.Transpose(NCB)
Sheet5.Range("A1").CurrentRegion.Borders.LineStyle = 1
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ vâng, em cám ơn nhiều nhiều ạ.
Sau này nếu em đổi vị trí hiện dữ liệu của các cột em xin hỏi anh dịch mã code với nhé.
Xin lỗi đã làm phiền anh dài dài.
 
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

Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
2
Đọc
43
ptm0412
ptm0412
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
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
14 15 16
Trả lời
309
Đọc
23K
ongke0711
ongke0711
H
Công thức tìm kết quả
Trả lời
11
Đọc
101
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
Huyen9
Lỗi không mailings được.
Trả lời
2
Đọc
46
Huyen9
Huyen9
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
70
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
124
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
118
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
116
VetMini
V
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
51
Đọc
103K
taimeanh
T
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
405
A HOANG 620
A
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
14
Đọc
544
htin1997
htin1997
tramcannt
Các bác cho hỏi làm cách nào để thu nhỏ thanh công thức này với ạ. Em cảm ơn.
Trả lời
2
Đọc
56
Nhattanktnn
Nhattanktnn
S
  • Question Question
Điều chỉnh kích thước dòng tự động theo trang in
Trả lời
5
Đọc
140
HUONGHCKT
H
A
Tạo vé Loto bằng Excel
2
Trả lời
20
Đọc
23K
Tuấn tata
Tuấn tata
Nauduong
Cách chuyển định dạng từ PDF sang Image
Trả lời
9
Đọc
262
Châu Bá Thông
Châu Bá Thông
minhduongct
  • Question Question
Viết code VBA thay cho dùng hàm vlookup
Trả lời
6
Đọc
1K
VetMini
V
N
Thử viết code lập trình đa luồng bằng TwinBasic và khả năng ứng dụng vào COM add-in chạy trong Excel
    • Thích
Trả lời
0
Đọc
171
nguyendang95
N
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
4
Đọc
226
Duy Tùng 9x
Duy Tùng 9x
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom