VBA tìm giá trị theo điều kiện (1 người xem)

[eagle12]

Chào các bác, xin nhờ anh chị về code VBA lấy giá trị theo điều kiện thay cho hàm sumifs cho bảng như sau ah

VD em có bảng dữ liệu sắp xếp "B3:Exxx",
Bảng báo cáo xoay sang chiều ngang với 2 dải điều kiên là cột H4:Hxxx và hàng I3:Uxxx

Em đang sử dụng hàm sumifs để lấy được số tiền của từng mã theo ngày

Xin nhờ anh chị code VBA lấy giá trị đổ vào từ ô I4:U thay cho hàm sumifs

 

[DeTong]

Trong khi chờ VBA Code, tham khảo kết quả M Code:

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Date Text", type date}, {"Mã", type text}, {"So tien", Currency.Type}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"Date Text", "Mã"}, {{"Count", each List.Sum([So tien]), Currency.Type }}),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Grouped Rows", {{"Date Text", type text}}, "vi-VN"), List.Distinct(Table.TransformColumnTypes(#"Grouped Rows", {{"Date Text", type text}}, "vi-VN")[#"Date Text"]), "Date Text", "Count", List.Sum)
in
    #"Pivoted Column"

 

[SA_DQ]

Một trong những phương thức rùa bò:

Sub TongHopMa_Ngay()
 Dim Dg As Long, Cot As Integer, Rws As Long
 Dim WF As Object, CSDL As Range, Cls As Range
 Dim Tmr As Double
 
 Tmr = Time()
 Rws = [C3].CurrentRegion.Rows.Count
 Set WF = Application.WorksheetFunction
 Set CSDL = [C3].Resize(Rws, 3)
 [I20].Value = [C3].Value:          [J20].Value = [D3].Value
 For Each Cls In Range([I3], [I3].End(xlToRight))
    [I21].Value = Cls.Value
    For Dg = 4 To 17
        [j21].Value = Cells(Dg, "H").Value
        Cells(Dg, Cls.Column).Value = WF.DSum(CSDL, [E3], [I20:J21])
    Next Dg
 Next Cls
 MsgBox Timer() - Tmr
End Sub

 

[eagle12]

Một trong những phương thức rùa bò:

Em thử chay code, KQ ra hiện ra không đúng anh ah, ví dụ I4
I4 <> E4,
I5 = E8 : OK

P/S: tại sheet1, có 2 code thay cho sumif nhiều đk, nhưng em không biết chỉnh lại cho phù hợp với dữ liệu của mình cần lấy khi vùng điều kiện là cột H4:H17 + hàng I3:U3

Cám ơn anh

 

[Hoàng Tuấn 868]

Xin nhờ anh chị code VBA lấy giá trị đổ vào từ ô I4:U thay cho hàm sumifs

Bạn xem thử file này.

 

[SA_DQ]

(1) Em thử chay code, KQ ra hiện ra không đúng anh ah, ví dụ I4
I4 <> E4,
I5 = E8 : OK

(2) P/S: tại sheet1, có 2 code thay cho sumif nhiều đk, nhưng em không biết chỉnh lại cho phù hợp với dữ liệu của mình cần lấy khi vùng điều kiện là cột H4:H17 + hàng I3:U3

Cám ơn anh

(1) Đó là do hệ mã của bạn không có cùng độ dài;
Ví du tính cho mã A1 sẽ lớn khác với tính cho A01 vì excel tài lanh tính cho cả A11, A10,. . .

(2) Chắc bạn chưa điêu luyện trong việc xài DSUM() mà thường xài SUMIF()
DSUM() cần được cung cấp 3 thông số
1./ Vùng dữ liệu (Trong macro là tham biến CSDL);
2./ Tiêu đề cột cần tính tổng;
3./ Vùng điều kiện (Ở đây tính tổng theo 2 điều kiện nên vùng điều kiện là 4 ô
[I20:J21]

 

[HUONGHCKT]

Chào các bác, xin nhờ anh chị về code VBA lấy giá trị theo điều kiện thay cho hàm sumifs cho bảng như sau ah

VD em có bảng dữ liệu sắp xếp "B3:Exxx",
Bảng báo cáo xoay sang chiều ngang với 2 dải điều kiên là cột H4:Hxxx và hàng I3:Uxxx

Em đang sử dụng hàm sumifs để lấy được số tiền của từng mã theo ngày

Xin nhờ anh chị code VBA lấy giá trị đổ vào từ ô I4:U thay cho hàm sumifs

View attachment 310243

Thử tham khảo code này xem sao

Sub TimKiem1()
Dim arr(), KQ(), Key
Dim Rng As Range, eRng As Range
Dim i&, Lr&, t&, d&, R&, Col&

With Sheets("Data")
    Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("B4:E" & Lr).Value
   .Range("H3:U3").Copy Sheets("BaoCao").Range("B2")
   .Range("H3:H17").Copy Sheets("BaoCao").Range("B2")
End With
Set Rng = Sheets("BaoCao").Range("A2:O2")
Set eRng = Sheets("BaoCao").Range("B1:B16")
R = UBound(arr)

ReDim KQ(1 To R, 1 To 364)

For i = 1 To R
    N = arr(i, 2)
    If Not Rng.Find(N) Is Nothing Then
        t = 0: t = Rng.Find(N).Column - 2
        If t > Col Then Col = t
        Key = arr(i, 3)
        If Not eRng.Find(Key) Is Nothing Then
            d = 0
            d = eRng.Find(Key).Row - 2
            KQ(d, t) = arr(i, 4) + KQ(d, t)
        End If
    End If
Next i
With Sheets("BaoCao")
   .Range("C3").Resize(100000, 1000).ClearContents
   .Range("C3").Resize(d, Col) = KQ
End With
   MsgBox "Done"
End Sub

Kết quả trả về B2/sheet BaoCao
Và nếu lấy toàn bộ các mã và các ngày (tức là vùng H3:U17/Sh Data = rỗng thì thử tham khảo code nông dân-củ chuối này xem thế nào. Kết quả trả về tại sheet baocao -Rất tiếc là ngày tháng không xếp theo đúng trình tự thời gian, tuy code chạy rất nhanh.
Mà cũng nói thật là chưa kiểm tra được kỹ tính chính xác của kết quả.

Sub TimKiem()
Dim arr(), KQ(), Key
Dim i&, j&, Lr&, t&, k&, R&
Dim DicN As Object
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Set DicN = CreateObject("Scripting.Dictionary")
With Sheets("Data")
Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
arr = .Range("B4:E" & Lr).Value
R = UBound(arr)
End With
ReDim KQ(1 To R, 1 To 364)
t = 1
For i = 1 To R
    N = CDate(arr(i, 2)):  Key = arr(i, 3)
    If Not DicN.Exists(N) Then t = t + 1: DicN.Add (N), t
    If Not Dic.Exists(Key) Then
        k = k + 1: Dic.Add (Key), k
        KQ(k, 1) = Key
        KQ(k, DicN.Item(N)) = arr(i, 4)
    Else
        d = Dic.Item(Key)
       KQ(d, DicN.Item(N)) = arr(i, 4) + KQ(d, DicN.Item(N))
    End If
Next i
If k Then
With Sheets("BaoCao")
   .Range("B3").Resize(100000, 1000).ClearContents
   .Range("B3").Resize(k, DicN.Count) = KQ
   .Range("C2").Resize(1, DicN.Count).Value = DicN.KeyS
   .Range("B2") = "Mã"
   End With
   End If
   Set DicN = Nothing
   Set Dic = Nothing
   MsgBox "Done"
End Sub

Xem file đính kèm

 

[eagle12]

Thử tham khảo code này xem sao

Cám ơn anh nhiều, xin lỗi anh em không nói rõ về KQ trả về

Em đang cần code chạy trả về KQ vào sheet báo cáo trong trường hợp cột mã & hàng ngày cho trước giá trị tham chiếu
Code sẽ đưa giá trị bằng với hàm sumifs như dưới, nếu mã và ngày không có trong bảng nguồn Data cột C-D-E thì sẽ trả giá trị = 0

Do file tính của em bảng nguồn ~3-400K dòng, và bảng báo cáo cũng dài, nên hàm sumifs em đang dùng chạy hơi chậm khi copy công thức tính vào anh ah

File này em gửi lại gồm cả 2 code ở post#7 anh làm hộ em, nhờ anh chỉnh lại giúp với ạ
Cám ơn anh

 

[HUONGHCKT]

Cám ơn anh nhiều, xin lỗi anh em không nói rõ về KQ trả về

Em đang cần code chạy trả về KQ vào sheet báo cáo trong trường hợp cột mã & hàng ngày cho trước giá trị tham chiếu
Code sẽ đưa giá trị bằng với hàm sumifs như dưới, nếu mã và ngày không có trong bảng nguồn Data cột C-D-E thì sẽ trả giá trị = 0

Do file tính của em bảng nguồn ~3-400K dòng, và bảng báo cáo cũng dài, nên hàm sumifs em đang dùng chạy hơi chậm khi copy công thức tính vào anh ah

File này em gửi lại gồm cả 2 code ở post#7 anh làm hộ em, nhờ anh chỉnh lại giúp với ạ
Cám ơn anh

View attachment 310255

Bạn chép 2 sub này vào 1 module và chạy thử từng sub xem nó khác biệt gì về thời gian tiêu tốn để hoàn thành nhé:

Sub TimKiem111()
Dim arr(), KQ(), Key
Dim Rng As Range, eRng As Range
Dim i&, Lr&, t&, d&, R&, Col&
Dim Ws As Worksheet
Dim Time
Time = Timer
With Sheets("Data")
    Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("B4:E" & Lr).Value
End With
Set Ws = Sheets("BaoCao")
Set Rng = Ws.Range(Ws.Cells(3, 2), Ws.Cells(3, Ws.Cells(3, Ws.Columns.Count).End(xlToLeft).Column))
Set eRng = Ws.Range("B3:B" & Ws.Range("B100000").End(xlUp).Row)
R = UBound(arr)

ReDim KQ(1 To eRng.Rows.Count + 1, 1 To Rng.Columns.Count)

For i = 1 To R
    N = arr(i, 2)
    If Not Rng.Find(N) Is Nothing Then
        t = 0: t = Rng.Find(N).Column - 2
        If t > Col Then Col = t
        Key = arr(i, 3)
        If Not eRng.Find(Key) Is Nothing Then
            d = 0:
            d = eRng.Find(Key).Row - 3
            KQ(d, t) = arr(i, 4) + KQ(d, t)
        End If
    End If
Next i
   Ws.Range("C4").Resize(100000, 1000).ClearContents
   Ws.Range("C4").Resize(eRng.Rows.Count, Col) = KQ
   MsgBox "Sub 11111 Done:" & Timer - Time
End Sub

Sub dùng Dictionary chạy thời gian khắc hẳn

Sub TimKiem22222()

Dim arr(), KQ(), Key
Dim i&, j&, Lr&, t&, k&, R&
Dim DicN As Object
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Set DicN = CreateObject("Scripting.Dictionary")
Dim Ws As Worksheet
Dim Time
Time = Timer
With Sheets("Data")
    Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("B4:E" & Lr).Value
End With
Set Ws = Sheets("BaoCao")
Set Rng = Ws.Range(Ws.Cells(3, 3), Ws.Cells(3, Ws.Cells(3, Ws.Columns.Count).End(xlToLeft).Column))
Set eRng = Ws.Range("B4:B" & Ws.Range("B100000").End(xlUp).Row)
R = UBound(arr)

ReDim KQ(1 To eRng.Rows.Count, 1 To Rng.Columns.Count)
For i = 1 To eRng.Rows.Count
    Key = eRng(i)
    If Not Dic.Exists(Key) Then Dic.Add (Key), i
Next i
For i = 1 To Rng.Columns.Count
    N = Rng(i)
     If Not DicN.Exists(N) Then DicN.Add (N), i
Next i

For i = 1 To R
    N = arr(i, 2):  Key = arr(i, 3)
    If DicN.Exists(N) Then
        t = DicN.Item(N)
        If Dic.Exists(Key) Then
            d = d + 1
            k = Dic.Item(Key)
            KQ(k, t) = arr(i, 4) + KQ(k, t)
        End If
    End If
Next i
If d Then
    Ws.Range("C4").Resize(100000, 1000).ClearContents
    Ws.Range("C4").Resize(Dic.Count, DicN.Count) = KQ
    MsgBox "Sub 2222 Xong:" & Timer - Time
End If
   Set DicN = Nothing
   Set Dic = Nothing
 
End Sub