Xin giúp đỡ sửa hoặc viết lại mã tính tổng theo nhiều điều kiện!

mrbomst · 2/6/21

Em xin kính chào tất cả mọi người ạ!
Em đang làm mã tổng hợp theo nhiều điều kiện bằng VBA nhưng do học mót và tự mày mò nên không biết cách viết nó như thế nào. mong các bác sửa hoặc viết giúp đỡ em với ạ.
Để bài đặt ra là em cần tính tổng các mã hàng phát sinh theo từng tháng. khi phát sinh vào tháng nào thì ghi dữ liệu tương ứng vào cột đấy.
Mong mọi người giúp đỡ em với ạ!

Mã:

Option Explicit
Sub KH_XUAT()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim MaxCls, Arr, ArrDK, Tk, KQ(), Ch(1 To 3), Tn, Dn, ID, i, j, n
Application.ScreenUpdating = False
Arr = Sheet1.Range("A4:J" & Sheet1.[B65536].End(3).Row) 'ma tai khoan
Tn = Sheet16.[I2]: Dn = Sheet16.[I3]                      'tu ngay - den ngay

'Dua bang MaTK va so du vao mang
For i = 1 To UBound(Arr, 1)  'tu dòng 1 den dong cuoi cung httk
If Not Dic.Exists(Arr(i, 2)) And Left(Arr(i, 2), 1) <> 0 Then
ID = ID + 1
Dic.Add IIf(IsNumeric(Arr(i, 2)), CStr(Arr(i, 2)), Trim(Arr(i, 2))), ID
ReDim Preserve KQ(1 To 22, 1 To ID)
KQ(1, ID) = Arr(i, 2)
KQ(2, ID) = Arr(i, 3)
KQ(3, ID) = Arr(i, 4)
KQ(4, ID) = Arr(i, 5)
KQ(5, ID) = Arr(i, 6)
KQ(6, ID) = Arr(i, 7)
KQ(7, ID) = Arr(i, 9)
End If
Next
Arr = Sheet5.Range("A5:T" & Sheet5.[B65536].End(3).Row)
ArrDK = Sheet16.Range("I2:T" & Sheet16.[I3].End(3).Row)
For i = 1 To UBound(Arr, 1)

        If Arr(i, 2) >= Tn And Arr(i, 2) <= Dn And Arr(i, 2) <> "" Then
        ID = Dic.Item(Arr(i, 10))
        KQ(8, ID) = KQ(8, ID) + Arr(i, 17)
        End If

On Error Resume Next
Next

j = 0
For i = 1 To UBound(KQ, 2)

j = j + 1
For n = 1 To 22
KQ(n, j) = KQ(n, i)
Next

Next
    With Sheet16
    .Rows("6:1000").EntireRow.Hidden = False
    .Range("B6:W1000").ClearContents
    End With
Sheet16.[B6:W6].Resize(j) = WorksheetFunction.Transpose(KQ)
    With Sheet16.Range("B6:B999")
    .SpecialCells(4).EntireRow.Hidden = True
    End With
End Sub

Maika8008 · 2/6/21

Tạm dùng cách này

mrbomst · 2/6/21

Maika8008 đã viết:
Tạm dùng cách này

cảm ơn bác đã giúp đỡ em ạ. không biết Function này có thể áp dụng cho nhiều trường hợp khác không bác nhỉ? và hiện tại thì em đang thấy hàm này không lấy được thông tin hàng hoá và số đầu kỳ. bác sửa giúp em được không ạ!

Maika8008 · 2/6/21

mrbomst đã viết:
cảm ơn bác đã giúp đỡ em ạ. không biết Function này có thể áp dụng cho nhiều trường hợp khác không bác nhỉ? và hiện tại thì em đang thấy hàm này không lấy được thông tin hàng hoá và số đầu kỳ. bác sửa giúp em được không ạ!

Việc lọc để điền số liệu đúng cột tháng phát sinh mới khó chứ lấy thông tin kia chỉ là chuyện nhỏ.

HieuCD · 3/6/21

mrbomst đã viết:

Em xin kính chào tất cả mọi người ạ!
Em đang làm mã tổng hợp theo nhiều điều kiện bằng VBA nhưng do học mót và tự mày mò nên không biết cách viết nó như thế nào. mong các bác sửa hoặc viết giúp đỡ em với ạ.
Để bài đặt ra là em cần tính tổng các mã hàng phát sinh theo từng tháng. khi phát sinh vào tháng nào thì ghi dữ liệu tương ứng vào cột đấy.
Mong mọi người giúp đỡ em với ạ!

Mã:

Option Explicit
Sub KH_XUAT()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim MaxCls, Arr, ArrDK, Tk, KQ(), Ch(1 To 3), Tn, Dn, ID, i, j, n
Application.ScreenUpdating = False
Arr = Sheet1.Range("A4:J" & Sheet1.[B65536].End(3).Row) 'ma tai khoan
Tn = Sheet16.[I2]: Dn = Sheet16.[I3]                      'tu ngay - den ngay

'Dua bang MaTK va so du vao mang
For i = 1 To UBound(Arr, 1)  'tu dòng 1 den dong cuoi cung httk
If Not Dic.Exists(Arr(i, 2)) And Left(Arr(i, 2), 1) <> 0 Then
ID = ID + 1
Dic.Add IIf(IsNumeric(Arr(i, 2)), CStr(Arr(i, 2)), Trim(Arr(i, 2))), ID
ReDim Preserve KQ(1 To 22, 1 To ID)
KQ(1, ID) = Arr(i, 2)
KQ(2, ID) = Arr(i, 3)
KQ(3, ID) = Arr(i, 4)
KQ(4, ID) = Arr(i, 5)
KQ(5, ID) = Arr(i, 6)
KQ(6, ID) = Arr(i, 7)
KQ(7, ID) = Arr(i, 9)
End If
Next
Arr = Sheet5.Range("A5:T" & Sheet5.[B65536].End(3).Row)
ArrDK = Sheet16.Range("I2:T" & Sheet16.[I3].End(3).Row)
For i = 1 To UBound(Arr, 1)

        If Arr(i, 2) >= Tn And Arr(i, 2) <= Dn And Arr(i, 2) <> "" Then
        ID = Dic.Item(Arr(i, 10))
        KQ(8, ID) = KQ(8, ID) + Arr(i, 17)
        End If

On Error Resume Next
Next

j = 0
For i = 1 To UBound(KQ, 2)

j = j + 1
For n = 1 To 22
KQ(n, j) = KQ(n, i)
Next

Next
    With Sheet16
    .Rows("6:1000").EntireRow.Hidden = False
    .Range("B6:W1000").ClearContents
    End With
Sheet16.[B6:W6].Resize(j) = WorksheetFunction.Transpose(KQ)
    With Sheet16.Range("B6:B999")
    .SpecialCells(4).EntireRow.Hidden = True
    End With
End Sub

Chạy sub

Mã:

Sub XYZ()
  Dim dic As Object, aMHang(), aXKho(), Res()
  Dim sRow&, sR&, i&, j&, k&, iR&, jC&

  Set dic = CreateObject("Scripting.Dictionary")
  With Sheets("MAHANG")
    aMHang = .Range("B4:I" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(aMHang)
  ReDim Res(1 To sRow, 1 To 21)
  For i = 1 To sRow
    If aMHang(i, 1) <> Empty Then
      dic.Item(aMHang(i, 1)) = i
      For j = 1 To 6
        Res(i, j) = aMHang(i, j)
      Next j
      Res(i, 7) = aMHang(i, 8)
    End If
  Next i
  With Sheets("XUATKHO")
    aXKho = .Range("C5:Q" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sR = UBound(aXKho)
  For i = 1 To sR
    iR = dic.Item(aXKho(i, 8))
    jC = Month(aXKho(i, 1)) + 7
    Res(iR, jC) = Res(iR, jC) + aXKho(i, 15)
    Res(iR, 20) = Res(iR, 20) + aXKho(i, 15)
  Next i
  For i = 1 To sRow
    If IsNumeric(Res(i, 7)) Then Res(i, 21) = Res(i, 7) - Res(i, 20)
  Next i
  With Sheets("KHXUAT")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("B6:V" & i).ClearContents
    .Range("B6:V6").Resize(sRow) = Res
  End With
End Sub

Xem file thêm công ty B

mrbomst · 3/6/21

Maika8008 đã viết:
Việc lọc để điền số liệu đúng cột tháng phát sinh mới khó chứ lấy thông tin kia chỉ là chuyện nhỏ.

dạ vâng. em cảm ơn bác đã giúp đỡ. em sẽ tìm hiểu thêm cách này ạ!

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

HieuCD đã viết:

Chạy sub

Mã:

Sub XYZ()
  Dim dic As Object, aMHang(), aXKho(), Res()
  Dim sRow&, sR&, i&, j&, k&, iR&, jC&

  Set dic = CreateObject("Scripting.Dictionary")
  With Sheets("MAHANG")
    aMHang = .Range("B4:I" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(aMHang)
  ReDim Res(1 To sRow, 1 To 21)
  For i = 1 To sRow
    If aMHang(i, 1) <> Empty Then
      dic.Item(aMHang(i, 1)) = i
      For j = 1 To 6
        Res(i, j) = aMHang(i, j)
      Next j
      Res(i, 7) = aMHang(i, 8)
    End If
  Next i
  With Sheets("XUATKHO")
    aXKho = .Range("C5:Q" & .Range("C" & Rows.Count).End(xlUp).Row).Value
  End With
  sR = UBound(aXKho)
  For i = 1 To sR
    iR = dic.Item(aXKho(i, 8))
    jC = Month(aXKho(i, 1)) + 7
    Res(iR, jC) = Res(iR, jC) + aXKho(i, 15)
    Res(iR, 20) = Res(iR, 20) + aXKho(i, 15)
  Next i
  For i = 1 To sRow
    If IsNumeric(Res(i, 7)) Then Res(i, 21) = Res(i, 7) - Res(i, 20)
  Next i
  With Sheets("KHXUAT")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("B6:V" & i).ClearContents
    .Range("B6:V6").Resize(sRow) = Res
  End With
End Sub

Xem file thêm công ty B

em cảm ơn bác ạ! mã này chạy dễ hiểu mà đúng theo mong muốn của em rồi ạ!

Maika8008 · 3/6/21

mrbomst đã viết:
dạ vâng. em cảm ơn bác đã giúp đỡ. em sẽ tìm hiểu thêm cách này ạ!

Hoàn thành việc lấy thông tin cho bạn

mrbomst · 3/6/21

Maika8008 đã viết:
Hoàn thành việc lấy thông tin cho bạn

em cảm ơn bác nhiều ạ!

Xin giúp đỡ sửa hoặc viết lại mã tính tổng theo nhiều điều kiện!

mrbomst

Thành viên mới

File đính kèm

Maika8008

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

File đính kèm

mrbomst

Thành viên mới

Maika8008

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

HieuCD

Chuyên gia GPE

File đính kèm

mrbomst

Thành viên mới

Maika8008

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

File đính kèm

mrbomst

Thành viên mới

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