Tách số tiền chi tiết theo từng mã đơn vị bằng VBA

[thinhnx22]

Trong file đính kèm, em cần tách chi tiết số tiền theo từng mã đơn vị. Em có mô tả cách làm trong file. Anh chị và các bạn hỗ trợ em với ạ. Em cảm ơn.

 

[BuiQuangThuan]

Trong file đính kèm, em cần tách chi tiết số tiền theo từng mã đơn vị. Em có mô tả cách làm trong file. Anh chị và các bạn hỗ trợ em với ạ. Em cảm ơn.

Thấy trong file có code đó chưa đáp ứng được việc bạn muốn à

 

[thinhnx22]

Thấy trong file có code đó chưa đáp ứng được việc bạn muốn à

Chắc mình quên chưa xoá code của file khác bạn ạ.

 

[HUONGHCKT]

Thấy trong file có code đó chưa đáp ứng được việc bạn muốn à

Đây này bạn:

Phân bổ chi phí theo điều kiện bằng VBA

Chào anh chị và các bạn, Trong file 3 có 3 sheet: Bang1,Bang2 và sheet ketqua. Bang1 là có chi phí chung theo từng tài khoản, bộ phận và khoản mục chi phí. Bang2 là chi phí chi tiết tương ứng với tỷ lệ của bộ phận và khoản mục chi phí. Sheet kết quả = chi phí chung * tỷ lệ chi tiết tương ứng...

www.giaiphapexcel.com

Trong đó mình cũng code cho bạn ấy, nhưng điều kiện tăng lên, bạn ấy nói chạy ra kết quả sai. sau đó bạn dùng code của anh bebo021..... Nếu có thời gian bạn xem code của mình trong đó giải thuật có gì sai không mà không ra kết quả mong đợi. Trân trọng.

 

[thinhnx22]

Đây này bạn:

Phân bổ chi phí theo điều kiện bằng VBA

Chào anh chị và các bạn, Trong file 3 có 3 sheet: Bang1,Bang2 và sheet ketqua. Bang1 là có chi phí chung theo từng tài khoản, bộ phận và khoản mục chi phí. Bang2 là chi phí chi tiết tương ứng với tỷ lệ của bộ phận và khoản mục chi phí. Sheet kết quả = chi phí chung * tỷ lệ chi tiết tương ứng...

www.giaiphapexcel.com

Trong đó mình cũng code cho bạn ấy, nhưng điều kiện tăng lên, bạn ấy nói chạy ra kết quả sai. sau đó bạn dùng code của anh bebo021..... Nếu có thời gian bạn xem code của mình trong đó giải thuật có gì sai không mà không ra kết quả mong đợi. Trân trọng.

Em chào anh. Đầu tiên xin cảm ơn anh vì đã hỗ trợ và giúp em ỏ chủ đề trước. Khi em thêm dữ liệu trong chủ đề trước thì chưa ra được kết quả mong muốn (Lúc đầu em sợ để dữ liệu dài quá thì mọi người khó hình dung, còn code lần đầu của anh với dữ liệu của em thì đúng rồi ạ). Nhưng em luôn trân trọng sự hỗ trợ của anh và các bạn trong diễn đàn. Còn ỏ chủ đề hiện tại, em đang thử theo phương án 2. Nếu phương án nào dễ làm hơn thì em sẽ áp dụng anh ạ. Em cảm ơn anh đã quan tâm đến chủ đề của em.

 

[BuiQuangThuan]

Chắc mình quên chưa xoá code của file khác bạn ạ.

Test tạm. Hên xui. . .

Option Explicit

Sub ABC()
Dim sArr(), Arr(), Res(), i&, ii&, K&, iR&
With Sheets("Bang2")
    iR = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:B" & iR).Value
End With
With Sheets("Bang1")
    iR = .Range("A" & Rows.Count).End(3).Row
    Arr = .Range("A2:D" & iR).Value
End With
ReDim Res(1 To UBound(sArr) * UBound(Arr) + UBound(Arr) - 1, 1 To 5)
For i = 1 To UBound(Arr)
    For ii = 1 To UBound(sArr)
        K = K + 1
        Res(K, 1) = Arr(i, 1)
        Res(K, 2) = Arr(i, 2)
        Res(K, 3) = Arr(i, 3)
        Res(K, 4) = sArr(ii, 1)
        Res(K, 5) = Arr(i, 4) * sArr(ii, 2)
    Next
    K = K + 1
Next
Sheets("Ketqua").Range("I2").Resize(K - 1, 5).Value = Res
End Sub

 

[thinhnx22]

Test tạm. Hên xui. . .

Option Explicit

Sub ABC()
Dim sArr(), Arr(), Res(), i&, ii&, K&, iR&
With Sheets("Bang2")
    iR = .Range("A" & Rows.Count).End(3).Row
    sArr = .Range("A2:B" & iR).Value
End With
With Sheets("Bang1")
    iR = .Range("A" & Rows.Count).End(3).Row
    Arr = .Range("A2:D" & iR).Value
End With
ReDim Res(1 To UBound(sArr) * UBound(Arr) + UBound(Arr) - 1, 1 To 5)
For i = 1 To UBound(Arr)
    For ii = 1 To UBound(sArr)
        K = K + 1
        Res(K, 1) = Arr(i, 1)
        Res(K, 2) = Arr(i, 2)
        Res(K, 3) = Arr(i, 3)
        Res(K, 4) = sArr(ii, 1)
        Res(K, 5) = Arr(i, 4) * sArr(ii, 2)
    Next
    K = K + 1
Next
Sheets("Ketqua").Range("I2").Resize(K - 1, 5).Value = Res
End Sub

Mình test vào cơ sở dữ liệu đầy đủ kết quả ra ok rồi bạn nhé. Cảm ơn bạn nhiều.