Tạo bảng tổng hợp thành tiền theo các Nhà cung cấp

[Nguyễn Hồng Quang]

Từ bảng dữ liệu chi tiết ; em muốn chạy code tạo ra bảng báo cáo tổng hợp thành tiền theo các nhà cung cấp.
tổng hợp thành tiền gồm:
tổng thành tiền của cột F x cột J (theo mã NCC) và
tổng thành tiền của cột F x cột L (theo mã NCC)
Chi tiết em đã trình bày trong file gửi kèm
Rất mong nhận được sự quan tâm giúp đỡ của các anh, chị và các bạn
Xin cảm ơn

 

[snow25]

Từ bảng dữ liệu chi tiết ; em muốn chạy code tạo ra bảng báo cáo tổng hợp thành tiền theo các nhà cung cấp.
tổng hợp thành tiền gồm:
tổng thành tiền của cột F x cột J (theo mã NCC) và
tổng thành tiền của cột F x cột L (theo mã NCC)
Chi tiết em đã trình bày trong file gửi kèm
Rất mong nhận được sự quan tâm giúp đỡ của các anh, chị và các bạn
Xin cảm ơn

Bạn thử code.

Sub linhtinh()
    Dim arr, arr1, dic As Object, i As Long, a As Long, lr As Long, lr1 As Long, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("baocao")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         .Range("C3:D" & lr).ClearContents
         arr = .Range("A3:D" & lr).Value
         For i = 1 To UBound(arr)
             dic.Item(arr(i, 1)) = i
         Next i
   End With
   With Sheets("data")
        lr1 = .Range("P" & Rows.Count).End(xlUp).Row
        arr1 = .Range("F3:P" & lr1).Value
        For i = 1 To UBound(arr1, 1)
            dk = arr1(i, 11)
            a = dic.Item(dk)
            If a Then
               arr(a, 3) = arr(a, 3) + arr1(i, 1) * arr1(i, 5)
               arr(a, 4) = arr(a, 4) + arr1(i, 1) * arr1(i, 7)
             End If
        Next i
    End With
    With Sheets("baocao")
         .Range("A3:D" & lr).Value = arr
    End With
End Sub

Bài đã được tự động gộp: 6/6/19

Từ bảng dữ liệu chi tiết ; em muốn chạy code tạo ra bảng báo cáo tổng hợp thành tiền theo các nhà cung cấp.
tổng hợp thành tiền gồm:
tổng thành tiền của cột F x cột J (theo mã NCC) và
tổng thành tiền của cột F x cột L (theo mã NCC)
Chi tiết em đã trình bày trong file gửi kèm
Rất mong nhận được sự quan tâm giúp đỡ của các anh, chị và các bạn
Xin cảm ơn

Bạn thử cái khác.

Sub linhtinh()
    Dim arr, arr1, dic As Object, i As Long, a As Long, lr As Long, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
   With Sheets("data")
        lr = .Range("P" & Rows.Count).End(xlUp).Row
        arr = .Range("F3:Q" & lr).Value
        ReDim arr1(1 To UBound(arr), 1 To 4)
        For i = 1 To UBound(arr, 1)
         If arr(i, 11) <> "Tong cong" Then
            dk = arr(i, 11)
            If Not dic.exists(dk) Then
               a = a + 1
               arr1(a, 1) = arr(i, 11)
               arr1(a, 2) = arr(i, 12)
               dic.Add dk, a
            End If
            b = dic.Item(dk)
            arr1(b, 3) = arr1(b, 3) + arr(i, 1) * arr(i, 5)
            arr1(b, 4) = arr1(b, 4) + arr(i, 1) * arr(i, 7)
         End If
        Next i
    End With
    With Sheets("baocao")
    lr = .Range("a" & Rows.Count).End(xlUp).Row
    If lr > 3 Then .Range("A3:D" & lr).ClearContents
      If a Then .Range("A3:D3").Resize(a).Value = arr1
    End With
End Sub

 

[Nguyễn Hồng Quang]

Bạn thử code.

Sub linhtinh()
    Dim arr, arr1, dic As Object, i As Long, a As Long, lr As Long, lr1 As Long, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("baocao")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         .Range("C3:D" & lr).ClearContents
         arr = .Range("A3:D" & lr).Value
         For i = 1 To UBound(arr)
             dic.Item(arr(i, 1)) = i
         Next i
   End With
   With Sheets("data")
        lr1 = .Range("P" & Rows.Count).End(xlUp).Row
        arr1 = .Range("F3:P" & lr1).Value
        For i = 1 To UBound(arr1, 1)
            dk = arr1(i, 11)
            a = dic.Item(dk)
            If a Then
               arr(a, 3) = arr(a, 3) + arr1(i, 1) * arr1(i, 5)
               arr(a, 4) = arr(a, 4) + arr1(i, 1) * arr1(i, 7)
             End If
        Next i
    End With
    With Sheets("baocao")
         .Range("A3:D" & lr).Value = arr
    End With
End Sub

Bài đã được tự động gộp: 6/6/19

Bạn thử cái khác.

Sub linhtinh()
    Dim arr, arr1, dic As Object, i As Long, a As Long, lr As Long, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
   With Sheets("data")
        lr = .Range("P" & Rows.Count).End(xlUp).Row
        arr = .Range("F3:Q" & lr).Value
        ReDim arr1(1 To UBound(arr), 1 To 4)
        For i = 1 To UBound(arr, 1)
         If arr(i, 11) <> "Tong cong" Then
            dk = arr(i, 11)
            If Not dic.exists(dk) Then
               a = a + 1
               arr1(a, 1) = arr(i, 11)
               arr1(a, 2) = arr(i, 12)
               dic.Add dk, a
            End If
            b = dic.Item(dk)
            arr1(b, 3) = arr1(b, 3) + arr(i, 1) * arr(i, 5)
            arr1(b, 4) = arr1(b, 4) + arr(i, 1) * arr(i, 7)
         End If
        Next i
    End With
    With Sheets("baocao")
    lr = .Range("a" & Rows.Count).End(xlUp).Row
    If lr > 3 Then .Range("A3:D" & lr).ClearContents
      If a Then .Range("A3:D3").Resize(a).Value = arr1
    End With
End Sub

Cảm ơn snow25 nhiều nhé. Code ra Kết quả đúng như mình mong muốn rồi. Chúc bạn ngày vui