Tạo công thức kết hợp tham chiếu và giá trị

Minh Ngọc LH · 21/9/23

Xin chào GPE
giúp em giải quyết code cho công thức ở cột màu vàng sheet A với ạ
Nội dung mong muốn như trong bức ảnh. do file khá nặng nên em hạn chế dùng công thức dò tìm nên tính viết code mà chưa được
Cảm ơn đã đọc bài và giúp đỡ ạ!

HUONGHCKT · 21/9/23

Minh Ngọc LH đã viết:
Xin chào GPE
giúp em giải quyết code cho công thức ở cột màu vàng sheet A với ạ
Nội dung mong muốn như trong bức ảnh. do file khá nặng nên em hạn chế dùng công thức dò tìm nên tính viết code mà chưa được
Cảm ơn đã đọc bài và giúp đỡ ạ!

Chạy thử code này (đã sửa lại code cũ)

Mã:

Sub test()
    Dim i As Long, dic As Object, lr As Long, arrA(), ArrB(), KQ(), dk As String, a
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("B")
        lr = .Range("D100000").End(xlUp).Row
        ArrB = .Range("D5:F" & lr).Value
        For i = 1 To UBound(ArrB, 1)
            dk = ArrB(i, 1) & "#" & ArrB(i, 2)
            If Not dic.exists(dk) Then
                dic(dk) = i
            End If
        Next
    End With
    With Sheets("A")
        lr = .Range("C100000").End(xlUp).Row
        arrA = .Range("C5:G" & lr).Value
ReDim KQ(1 To UBound(arrA), 1 To 1)

        For i = 1 To UBound(arrA, 1)
            dk = arrA(i, 1) & "#" & arrA(i, 2)
            If dic.exists(dk) Then
                a = dic(dk)
                KQ(i, 1) = arrA(i, 3) + arrA(i, 4) - arrA(i, 5) - ArrB(a, 3)
            Else
                KQ(i, 1) = arrA(i, 3) + arrA(i, 4) - arrA(i, 5)
            End If
            
        Next
.Range("I5").Resize(UBound(arrA, 1), 1) = KQ
    End With

    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Lưu ý kết quả đang để ở I5

Minh Ngọc LH · 21/9/23

HUONGHCKT đã viết:

Chạy thử code này (đã sửa lại code cũ)

Mã:

Sub test()
    Dim i As Long, dic As Object, lr As Long, arrA(), ArrB(), KQ(), dk As String, a
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("B")
        lr = .Range("D100000").End(xlUp).Row
        ArrB = .Range("D5:F" & lr).Value
        For i = 1 To UBound(ArrB, 1)
            dk = ArrB(i, 1) & "#" & ArrB(i, 2)
            If Not dic.exists(dk) Then
                dic(dk) = i
            End If
        Next
    End With
    With Sheets("A")
        lr = .Range("C100000").End(xlUp).Row
        arrA = .Range("C5:G" & lr).Value
ReDim KQ(1 To UBound(arrA), 1 To 1)

        For i = 1 To UBound(arrA, 1)
            dk = arrA(i, 1) & "#" & arrA(i, 2)
            If dic.exists(dk) Then
                a = dic(dk)
                KQ(i, 1) = arrA(i, 3) + arrA(i, 4) - arrA(i, 5) - ArrB(a, 3)
            Else
                KQ(i, 1) = arrA(i, 3) + arrA(i, 4) - arrA(i, 5)
            End If
           
        Next
.Range("I5").Resize(UBound(arrA, 1), 1) = KQ
    End With

    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Lưu ý kết quả đang để ở I5

Do file khá nặng nên cũng muốn dán luôn giá trị vào có điều người ta yêu cầu ở cột đó hiện công thức. chứ nếu tính ra giá trị và gán vào thì lại đơn giản rồi ạ.

VetMini · 21/9/23

HUONGHCKT đã viết:
Chạy thử code này (đã sửa lại code cũ)
....
Lưu ý kết quả đang để ở I5

Rồi. Trúng quả này nuốt được mới hay.
File nặng cho nên không muốn dùng công thức. Dùng code nhưng lại muốn hiện công thức.
Lưu ý dòng tô đậm ở dưới. Trình độ tính ra giá trị và gán vào là đơn giản đối với thớt.

Minh Ngọc LH đã viết:
Do file khá nặng nên cũng muốn dán luôn giá trị vào có điều người ta yêu cầu ở cột đó hiện công thức. chứ nếu tính ra giá trị và gán vào thì lại đơn giản rồi ạ.

"Hiện" bằng cách nào tôi chưa nghĩ ra.
1. Ghi công thức vào comments cho cột
2. Đặt event cell selected (selection change), hiển thị công thức.
Cả hai cách đều chả giải quyết được "file nặng"

HUONGHCKT · 21/9/23

Tôi cho rằng : giữa tôi và bạn, 1 trong hai người có vấn đề về đọc hiểu
Bạn đã viết yêu cầu

Minh Ngọc LH đã viết:
Xin chào GPE
giúp em giải quyết code cho công thức ở cột màu vàng sheet A với ạ
Nội dung mong muốn như trong bức ảnh. do file khá nặng nên em hạn chế dùng công thức dò tìm nên tính viết code mà chưa được
Cảm ơn đã đọc bài và giúp đỡ ạ!

Đến khi có code rồi thì bạn lại:

Minh Ngọc LH đã viết:
Do file khá nặng nên cũng muốn dán luôn giá trị vào có điều người ta yêu cầu ở cột đó hiện công thức. chứ nếu tính ra giá trị và gán vào thì lại đơn giản rồi ạ.

Vậy thì tóm lại là bạn muốn gì?
Đơn giản à? Thành thật xin lỗi bạn vì đã sửa lại code cho bạn mà lại không đúng ý bạn (một siêu cao thủ VBA ẩn mình).
Mà sao hôm nay là ngày gì mà tôi có diễm phúc được tương tác với nhiều "Chuyên gia VBA ẩn mình" đến thế : bạn trước (là người có văn hóa) thì còn nhận được lời cảm ơn, còn bạn chủ thớt này thì......

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

VetMini đã viết:
Rồi. Trúng quả này nuốt được mới hay.
File nặng cho nên không muốn dùng công thức. Dùng code nhưng lại muốn hiện công thức.
Lưu ý dòng tô đậm ở dưới. Trình độ tính ra giá trị và gán vào là đơn giản đối với thớt.

"Hiện" bằng cách nào tôi chưa nghĩ ra.
1. Ghi công thức vào comments cho cột
2. Đặt event cell selected (selection change), hiển thị công thức.
Cả hai cách đều chả giải quyết được "file nặng"

Cảm ơn anh đã xem bài.
Quả này tôi chào thua, vái nạy và rút lui rồi

bebo021999 · 22/9/23

Thôi thì làm đại.
Khi click vào ô thì CT sẽ hiện lên, không thì thôi (Dùng DataValidation)
Đã tính cả trường hợp nếu tồn kho<0 thì trả về 0 (Lỗi nhiều hơn tồn kho)
Phần add comment, vẫn phải loop qua từng cell, không có cách nào khác.

PHP:

Option Explicit
Sub cuoiky()
Dim i&, rng, kq, res(), id As String, fm As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
rng = Sheets("B").Range("D4").CurrentRegion.Value
For i = 2 To UBound(rng)
    id = rng(i, 1) & rng(i, 2)
    If Not dic.exists(id) Then
        dic.Add rng(i, 1) & rng(i, 2), rng(i, 3)
    Else
        dic(rng(i, 1) & rng(i, 2)) = dic(rng(i, 1) & rng(i, 2)) + rng(i, 3)
    End If
Next
rng = Range("C4").CurrentRegion.Value
For i = 2 To UBound(rng)
    id = rng(i, 1) & rng(i, 2)
    fm = "=E" & i + 3 & "+F" & i + 3 & "-G" & i + 3
    kq = rng(i, 3) + rng(i, 4) - rng(i, 5)
    If dic.exists(id) Then
        If kq >= dic(id) Then
            kq = kq - dic(id)
            fm = fm & "-" & dic(id)
            dic.Remove id
        Else
            dic(id) = dic(id) - kq
            fm = fm & "-" & kq
            kq = 0
        End If
    End If
    rng(i, 6) = kq
    With Cells(i + 3, "H").Validation
        .Delete
        .Add Type:=xlValidateInputOnly
        .InputMessage = fm
    End With
Next
Range("C4:H100000").ClearContents
Range("C4").Resize(UBound(rng), UBound(rng, 2)).Value = rng
End Sub

Minh Ngọc LH · 22/9/23

bebo021999 đã viết:

Thôi thì làm đại.
Khi click vào ô thì CT sẽ hiện lên, không thì thôi (Dùng DataValidation)
Đã tính cả trường hợp nếu tồn kho<0 thì trả về 0 (Lỗi nhiều hơn tồn kho)
Phần add comment, vẫn phải loop qua từng cell, không có cách nào khác.

PHP:

Option Explicit
Sub cuoiky()
Dim i&, rng, kq, res(), id As String, fm As String, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
rng = Sheets("B").Range("D4").CurrentRegion.Value
For i = 2 To UBound(rng)
    id = rng(i, 1) & rng(i, 2)
    If Not dic.exists(id) Then
        dic.Add rng(i, 1) & rng(i, 2), rng(i, 3)
    Else
        dic(rng(i, 1) & rng(i, 2)) = dic(rng(i, 1) & rng(i, 2)) + rng(i, 3)
    End If
Next
rng = Range("C4").CurrentRegion.Value
For i = 2 To UBound(rng)
    id = rng(i, 1) & rng(i, 2)
    fm = "=E" & i + 3 & "+F" & i + 3 & "-G" & i + 3
    kq = rng(i, 3) + rng(i, 4) - rng(i, 5)
    If dic.exists(id) Then
        If kq >= dic(id) Then
            kq = kq - dic(id)
            fm = fm & "-" & dic(id)
            dic.Remove id
        Else
            dic(id) = dic(id) - kq
            fm = fm & "-" & kq
            kq = 0
        End If
    End If
    rng(i, 6) = kq
    With Cells(i + 3, "H").Validation
        .Delete
        .Add Type:=xlValidateInputOnly
        .InputMessage = fm
    End With
Next
Range("C4:H100000").ClearContents
Range("C4").Resize(UBound(rng), UBound(rng, 2)).Value = rng
End Sub

Cảm ơn bác đã giúp đỡ! Dựa trên code của bác, cháu chế biến lại theo phong cách của cháu

PHP:

Sub test()
    Dim i As Long, dic As Object, lr As Long, arr(), dk As String, fm As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("B")
        lr = .Range("D100000").End(xlUp).Row
        arr = .Range("D5:F" & lr).Value
        For i = 1 To UBound(arr, 1)
            dk = arr(i, 1) & "#" & arr(i, 2)
            If Not dic.exists(dk) Then
                dic.Add (dk), arr(i, 3)
            Else
                dic.Item(dk) = dic.Item(dk) + arr(i, 3)
            End If
        Next
    End With
    With Sheets("A")
        lr = .Range("C100000").End(xlUp).Row
        arr = .Range("C5:H" & lr).Value
        For i = 1 To UBound(arr, 1)
            dk = arr(i, 1) & "#" & arr(i, 2)
            If dic.exists(dk) Then
                fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4 & "-" & dic.Item(dk)
                arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5) - dic.Item(dk)
                dic.Remove dk
                If arr(i, 6) < 0 Then
                    MsgBox ("Cuoi ky o H" & i + 4 & " bi am. Vui long kiem tra lai!")
                End If
            Else
                fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4
                arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5)
            End If
            With Cells(i + 4, "H").Validation
                .Delete
                .Add Type:=xlValidateInputOnly
                .InputMessage = fm
            End With
        Next
        .Range("C5:H" & lr) = arr
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

bebo021999 · 22/9/23

Code mới:

PHP:

If dic.exists(dk) Then
    fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4 & "-" & dic.Item(dk)
    arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5) - dic.Item(dk)
    dic.Remove dk
    If arr(i, 6) < 0 Then
        MsgBox ("Cuoi ky o H" & i + 4 & " bi am. Vui long kiem tra lai!")
    End If
Else
    fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4
    arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5)
End If

Sao bạn không đưa cái fm và arr(i,6) lên đằng trước cái IF dic (Như code cũ mình làm)?
Và khi check cái dic thì add thêm cái đuôi dic.Item(dk) vào (hoặc giữ nguyên) thì gọn hơn.

Minh Ngọc LH · 22/9/23

bebo021999 đã viết:
Code mới:

PHP:

If dic.exists(dk) Then fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4 & "-" & dic.Item(dk) arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5) - dic.Item(dk) dic.Remove dk If arr(i, 6) < 0 Then MsgBox ("Cuoi ky o H" & i + 4 & " bi am. Vui long kiem tra lai!") End If Else fm = "=E" & i + 4 & "+F" & i + 4 & "-G" & i + 4 arr(i, 6) = arr(i, 3) + arr(i, 4) - arr(i, 5) End If

Sao bạn không đưa cái fm và arr(i,6) lên đằng trước cái IF dic (Như code cũ mình làm)?
Và khi check cái dic thì add thêm cái đuôi dic.Item(dk) vào (hoặc giữ nguyên) thì gọn hơn.

Dạ lúc đọc được bài trả lời của bác thì làm tiếp luôn theo code cũ nên cũng chưa suy nghĩ làm sao để code đẹp gọn như của bác.

Minh Ngọc LH · 25/9/23

Minh Ngọc LH đã viết:
Dạ lúc đọc được bài trả lời của bác thì làm tiếp luôn theo code cũ nên cũng chưa suy nghĩ làm sao để code đẹp gọn như của bác.

Không cần dao to búa lớn gì nhé bác. Chỉ cần gắn kết quả của hàng lỗi vào sau công thức tham chiếu là được rồi ạ. Trước đây là trừ hàng lỗi ở phía trong công thức tham chiếu nên excel không cho

PHP:

Sub test()
    Dim i As Long, dic As Object, arr(), dk As String
 
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheets("B").Range("D4").CurrentRegion.Value
    For i = 2 To UBound(arr, 1)
        dk = arr(i, 1) & "#" & arr(i, 2)
        If Not dic.exists(dk) Then
            dic.Add (dk), arr(i, 3)
        Else
            dic.exists(dk) = dic.exists(dk) + arr(i, 3)
        End If
    Next
    arr = Sheets("A").Range("D4").CurrentRegion.Value
    For i = 2 To UBound(arr, 1)
        dk = arr(i, 1) & "#" & arr(i, 2)
        If dic.exists(dk) Then
            Sheets("A").Cells(i + 3, 8).FormulaR1C1 = "=RC[-3]+RC[-2]-RC[-1]-" & dic.Item(dk)
        Else
            Sheets("A").Cells(i + 3, 8).FormulaR1C1 = "=RC[-3]+RC[-2]-RC[-1]"
        End If
    Next
End Sub

VetMini · 25/9/23

Rồi. Có nhiều khả năng gặp người quen cũ

Tạo công thức kết hợp tham chiếu và giá trị

Minh Ngọc LH

Thành viên chính thức

File đính kèm

HUONGHCKT

Zalo 0986997214

Minh Ngọc LH

Thành viên chính thức

VetMini

Ăn cùng góc phố

HUONGHCKT

Zalo 0986997214

bebo021999

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

File đính kèm

Minh Ngọc LH

Thành viên chính thức

File đính kèm

bebo021999

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

Minh Ngọc LH

Thành viên chính thức

Minh Ngọc LH

Thành viên chính thức

File đính kèm

VetMini

Ăn cùng góc phố

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