Tạo báo cáo kho

[Hoangquyenbong]

Xin chào các thành viên của diễn đàn !
Mình có file dữ liệu muốn nhờ diễn đàn viết giúp câu lệnh VBA để tạo file báo cáo tồn kho theo mẫu mình đã gửi kèm dưới đây ạ. Chi tiết yêu cầu của báo cáo mình đã ghi chú trong file luôn ạ. Mong mọi người viết giúp mình với ạ. Số lượng dòng hàng của báo cáo có thay đổi với lượng dòng tương đối nhiều. Nếu trong quá trình xem bài có điểm nào chưa hiểu mình sẽ giải thích rõ hơn.
Mình cảm ơn nhiều !

 

[Hoangquyenbong]

Mong thành viên trên diễn đàn viết code giúp mình với ạ.
Mình cảm ơn nhiều !

 

[HieuCD]

Xin chào các thành viên của diễn đàn !
Mình có file dữ liệu muốn nhờ diễn đàn viết giúp câu lệnh VBA để tạo file báo cáo tồn kho theo mẫu mình đã gửi kèm dưới đây ạ. Chi tiết yêu cầu của báo cáo mình đã ghi chú trong file luôn ạ. Mong mọi người viết giúp mình với ạ. Số lượng dòng hàng của báo cáo có thay đổi với lượng dòng tương đối nhiều. Nếu trong quá trình xem bài có điểm nào chưa hiểu mình sẽ giải thích rõ hơn.
Mình cảm ơn nhiều !

Hai báo cáo nên để ở 2 sheet khác nhau, tạo thêm sheet "Ketqua2"

Sub XYZ()
  Dim sArr(), Res(), Res1(), Res2, Res3, Res4, Dic As Object
  Dim sRow&, sCol&, i&, j&, k&, k2&
  Dim ymp$, stype$, stMau$
 
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("Ketqua2")
    sArr = .Range("C4:V6").Value
  End With
  sCol = UBound(sArr, 2)
  For j = 4 To sCol - 1
    For i = 1 To 3
      Dic.Add sArr(i, j), j
    Next i
  Next j
 
  With Sheets("File dulieu")
    sArr = .Range("A5:L" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To sCol)
  ReDim Res1(1 To sRow * 2, 1 To 1)
  Res2 = Res1:    Res3 = Res1:    Res4 = Res1
 
  k2 = -1
  For i = 1 To sRow
    If stMau <> sArr(i, 3) & "|" & sArr(i, 5) Then
      stMau = sArr(i, 3) & "|" & sArr(i, 5)
      k = k + 1
      Res(k, 1) = sArr(i, 3)
      If sArr(i, 12) = Empty Then Res(k, 2) = Res(k - 1, 2) Else Res(k, 2) = sArr(i, 12)
      Res(k, 3) = sArr(i, 5)
    End If
    Res(k, Dic.Item(sArr(i, 6))) = sArr(i, 4)
    Res(k, sCol) = Res(k, sCol) + sArr(i, 4)
    
    tmp = sArr(i, 3) & "|" & Int((CLng(sArr(i, 6)) + 20) / 40)
    If stype <> tmp Then
      stype = tmp
      k2 = k2 + 2
      Res1(k2, 1) = sArr(i, 3): Res1(k2 + 1, 1) = sArr(i, 11)
      Res2(k2, 1) = sArr(i, 10): Res2(k2 + 1, 1) = sArr(i, 12)
      Res3(k2, 1) = sArr(i, 1)
      Res4(k2, 1) = sArr(i, 8)
    End If
    Res3(k2 + 1, 1) = Res3(k2 + 1, 1) + sArr(i, 4)
  Next i
 
  With Sheets("Ketqua")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:W" & i).Clear
    .Range("B2:W3").Copy .Range("B4:W" & k2 + 2)
    .Range("C2").Resize(k2 + 1) = Res1
    .Range("E2").Resize(k2 + 1) = Res2
    .Range("Q2").Resize(k2 + 1) = Res3
    .Range("V2").Resize(k2 + 1) = Res4
  End With
 
  With Sheets("Ketqua2")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > 6 Then .Range("B7:W" & i).Clear
    .Range("C7").Resize(k, sCol) = Res
    .Range("B7").Resize(k, sCol + 2).Borders.LineStyle = 1
  End With
End Sub

 

[Hoangquyenbong]

Hai báo cáo nên để ở 2 sheet khác nhau, tạo thêm sheet "Ketqua2"

Sub XYZ()
  Dim sArr(), Res(), Res1(), Res2, Res3, Res4, Dic As Object
  Dim sRow&, sCol&, i&, j&, k&, k2&
  Dim ymp$, stype$, stMau$

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("Ketqua2")
    sArr = .Range("C4:V6").Value
  End With
  sCol = UBound(sArr, 2)
  For j = 4 To sCol - 1
    For i = 1 To 3
      Dic.Add sArr(i, j), j
    Next i
  Next j

  With Sheets("File dulieu")
    sArr = .Range("A5:L" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To sCol)
  ReDim Res1(1 To sRow * 2, 1 To 1)
  Res2 = Res1:    Res3 = Res1:    Res4 = Res1

  k2 = -1
  For i = 1 To sRow
    If stMau <> sArr(i, 3) & "|" & sArr(i, 5) Then
      stMau = sArr(i, 3) & "|" & sArr(i, 5)
      k = k + 1
      Res(k, 1) = sArr(i, 3)
      If sArr(i, 12) = Empty Then Res(k, 2) = Res(k - 1, 2) Else Res(k, 2) = sArr(i, 12)
      Res(k, 3) = sArr(i, 5)
    End If
    Res(k, Dic.Item(sArr(i, 6))) = sArr(i, 4)
    Res(k, sCol) = Res(k, sCol) + sArr(i, 4)
   
    tmp = sArr(i, 3) & "|" & Int((CLng(sArr(i, 6)) + 20) / 40)
    If stype <> tmp Then
      stype = tmp
      k2 = k2 + 2
      Res1(k2, 1) = sArr(i, 3): Res1(k2 + 1, 1) = sArr(i, 11)
      Res2(k2, 1) = sArr(i, 10): Res2(k2 + 1, 1) = sArr(i, 12)
      Res3(k2, 1) = sArr(i, 1)
      Res4(k2, 1) = sArr(i, 8)
    End If
    Res3(k2 + 1, 1) = Res3(k2 + 1, 1) + sArr(i, 4)
  Next i

  With Sheets("Ketqua")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:W" & i).Clear
    .Range("B2:W3").Copy .Range("B4:W" & k2 + 2)
    .Range("C2").Resize(k2 + 1) = Res1
    .Range("E2").Resize(k2 + 1) = Res2
    .Range("Q2").Resize(k2 + 1) = Res3
    .Range("V2").Resize(k2 + 1) = Res4
  End With

  With Sheets("Ketqua2")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > 6 Then .Range("B7:W" & i).Clear
    .Range("C7").Resize(k, sCol) = Res
    .Range("B7").Resize(k, sCol + 2).Borders.LineStyle = 1
  End With
End Sub

Dạ em cảm ơn anh nhiều ạ !
Đã chạy kết quả như em mong muốn rồi ạ.