Gán giá trị xuống sheet theo mã cho trước của Dictionary

Minh Tùng · 19/11/19

Em đã tạo được tổng số lượng theo mã hàng bằng Dictionary nhưng lay hoay mãi vẫn không gán được xuống sheet theo mã cho trước.
Anh chị giúp em phần này ạ.
File đính kèm bên dưới.
Cám ơn anh/chị nhiều.

batman1 · 19/11/19

Mã:

For i = 1 To UBound(Arri)
    Dic(Arri(i, 1)) = Empty  'Lay thanh phan cot 1 vao Dic
Next i
ReDim ArrO(1 To Dic.Count, 1 To Lc) 'Redim lai mang
Dic.RemoveAll

???
Vòng For và thêm vào dic để làm gì khi mà ngay sau đó xóa nội dung của dic?

Muốn Redim thì dễ thôi

Mã:

ReDim ArrO(1 To UBound(Arri), 1 To UBound(Arri, 2))

------------
Yêu cầu: Các Mã ở cột I bắt đầu từ I2. Không bắt buộc các Mã phải liên tục trong cột I - cho phép các ô trống đan xen.
Dữ liệu bắt đầu từ dòng 2, từ cột A.

Mã:

Sub SumByDic()
    On Error Resume Next
    Dim Lr, Lc, i, j, k As Long, Arri(), ArrO(), Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        Lr = .Range("I" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Arri = .Range("I2:I" & Lr + 1).Value
'        cho cac Ma o cot I vao dic
        For k = 1 To UBound(Arri) - 1
            If Arri(k, 1) <> "" Then
                i = k
                Dic.Add Arri(k, 1), k
            End If
        Next k
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        If Lc < 2 Then Exit Sub
        Arri = .Range("A2", .Cells(Lr, Lc)).Value
        ReDim ArrO(1 To i, 1 To Lc - 1)
    End With
    For i = 1 To UBound(Arri) 'Cho bien i chay tu 1 den cuoi mang vao
'        chi xet cac Ma o cot A ma co trong cot ket qua I
        If Dic.exists(Arri(i, 1)) Then
            k = Dic.Item(Arri(i, 1))
            For j = 1 To UBound(ArrO, 2)
                ArrO(k, j) = ArrO(k, j) + Arri(i, j + 1)
            Next j
        End If
    Next i
    Sheet1.Range("J2").Resize(UBound(ArrO), UBound(ArrO, 2)) = ArrO
    Set Dic = Nothing
End Sub

Minh Tùng · 19/11/19

Anh @batman1 thông cảm giúp em. Em mới tập tành món VBA này có vài tháng à, hihi.
Có gì anh chỉ bảo em thêm ạ.
Cám ơn anh nhiều nhé!

Minh Tùng · 19/11/19

batman1 đã viết:

Mã:

For i = 1 To UBound(Arri)
    Dic(Arri(i, 1)) = Empty  'Lay thanh phan cot 1 vao Dic
Next i
ReDim ArrO(1 To Dic.Count, 1 To Lc) 'Redim lai mang
Dic.RemoveAll

???
Vòng For và thêm vào dic để làm gì khi mà ngay sau đó xóa nội dung của dic?

Muốn Redim thì dễ thôi

Mã:

ReDim ArrO(1 To UBound(Arri), 1 To UBound(Arri, 2))

------------
Yêu cầu: Các Mã ở cột I bắt đầu từ I2. Không bắt buộc các Mã phải liên tục trong cột I - cho phép các ô trống đan xen.
Dữ liệu bắt đầu từ dòng 2, từ cột A.

Mã:

Sub SumByDic()
    On Error Resume Next
    Dim Lr, Lc, i, j, k As Long, Arri(), ArrO(), Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        Lr = .Range("I" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Arri = .Range("I2:I" & Lr + 1).Value
'        cho cac Ma o cot I vao dic
        For k = 1 To UBound(Arri) - 1
            If Arri(k, 1) <> "" Then
                i = k
                Dic.Add Arri(k, 1), k
            End If
        Next k
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        If Lc < 2 Then Exit Sub
        Arri = .Range("A2", .Cells(Lr, Lc)).Value
        ReDim ArrO(1 To i, 1 To Lc - 1)
    End With
    For i = 1 To UBound(Arri) 'Cho bien i chay tu 1 den cuoi mang vao
'        chi xet cac Ma o cot A ma co trong cot ket qua I
        If Dic.exists(Arri(i, 1)) Then
            k = Dic.Item(Arri(i, 1))
            For j = 1 To UBound(ArrO, 2)
                ArrO(k, j) = ArrO(k, j) + Arri(i, j + 1)
            Next j
        End If
    Next i
    Sheet1.Range("J2").Resize(UBound(ArrO), UBound(ArrO, 2)) = ArrO
    Set Dic = Nothing
End Sub

Nếu em muốn bỏ luôn text của cột J và K, chỉ lấy số lượng bắt đầu tại cột J thì sửa code ở đoạn nào anh @batman1
Giúp em nhé!

batman1 · 20/11/19

Nếu cột B, C vẫn có dữ liệu nhưng kết quả chỉ là số và ở J:M thì

Mã:

Sub SumByDic()
    On Error Resume Next
    Dim Lr, Lc, i, j, k As Long, Arri(), ArrO(), Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        Lr = .Range("I" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Arri = .Range("I2:I" & Lr + 1).Value
'        cho cac Ma o cot I vao dic
        For k = 1 To UBound(Arri) - 1
            If Arri(k, 1) <> "" Then
                i = k
                Dic.Add Arri(k, 1), k
            End If
        Next k
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        If Lc < 4 Then Exit Sub
        Arri = .Range("A2", .Cells(Lr, Lc)).Value
        ReDim ArrO(1 To i, 1 To Lc - 3)
    End With
    For i = 1 To UBound(Arri) 'Cho bien i chay tu 1 den cuoi mang vao
'        chi xet cac Ma o cot A ma co trong cot ket qua I
        If Dic.exists(Arri(i, 1)) Then
            k = Dic.Item(Arri(i, 1))
            For j = 1 To UBound(ArrO, 2)
                ArrO(k, j) = ArrO(k, j) + Arri(i, j + 3)
            Next j
        End If
    Next i
    Sheet1.Range("J2").Resize(UBound(ArrO), UBound(ArrO, 2)) = ArrO
    Set Dic = Nothing
End Sub

So sánh 2 code thì bạn biết tôi đã sửa ở đâu

Minh Tùng · 20/11/19

batman1 đã viết:

Nếu cột B, C vẫn có dữ liệu nhưng kết quả chỉ là số và ở J:M thì

Mã:

Sub SumByDic()
    On Error Resume Next
    Dim Lr, Lc, i, j, k As Long, Arri(), ArrO(), Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        Lr = .Range("I" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Arri = .Range("I2:I" & Lr + 1).Value
'        cho cac Ma o cot I vao dic
        For k = 1 To UBound(Arri) - 1
            If Arri(k, 1) <> "" Then
                i = k
                Dic.Add Arri(k, 1), k
            End If
        Next k
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 2 Then Exit Sub
        Lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        If Lc < 4 Then Exit Sub
        Arri = .Range("A2", .Cells(Lr, Lc)).Value
        ReDim ArrO(1 To i, 1 To Lc - 3)
    End With
    For i = 1 To UBound(Arri) 'Cho bien i chay tu 1 den cuoi mang vao
'        chi xet cac Ma o cot A ma co trong cot ket qua I
        If Dic.exists(Arri(i, 1)) Then
            k = Dic.Item(Arri(i, 1))
            For j = 1 To UBound(ArrO, 2)
                ArrO(k, j) = ArrO(k, j) + Arri(i, j + 3)
            Next j
        End If
    Next i
    Sheet1.Range("J2").Resize(UBound(ArrO), UBound(ArrO, 2)) = ArrO
    Set Dic = Nothing
End Sub

So sánh 2 code thì bạn biết tôi đã sửa ở đâu

Em cám ơn anh trước nhé, sáng mai em kiểm tra và test lại code.
Chúc anh và GPE ngủ ngon ạ. Hihi!

Gán giá trị xuống sheet theo mã cho trước của Dictionary

Minh Tùng

Thành viên hoạt động

File đính kèm

batman1

Thành viên gạo cội

File đính kèm

Minh Tùng

Thành viên hoạt động

Minh Tùng

Thành viên hoạt động

File đính kèm

batman1

Thành viên gạo cội

Minh Tùng

Thành viên hoạt động

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

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