Tính giá sản phẩm theo từng hệ số cho trước (1 người xem)

ketoanvien1985 · 7/9/15

Xin Chào Anh Chị GPE,

Hiện tại em đang làm form và có lum lặc trên diễn đàn code và bào chế lại, nhưng hiện tại nó không chạy đúng yêu cầu

Sheet 1 gồm tên hàng ( Cột C), nhãn hiệu (Cột F)và giá thành ( Cột M)
Sheet 2 là nhãn hiệu và hệ số giá thành của từng nhãn hiệu

Sheet1_giá tại Cột P = giá cột M chia cho cột E bên Sheet 2. ( Sản phẩm nào thì sẽ chia cho hệ số của sản phẩm đó).

Cột Q = Cột P - Cột M

Mong Anh Chị xem giúp code của em bị sai chổ nào nha.

ketoanvien1985 · 8/9/15

Nhờ anh chị xem code này giúp em với ạ, nó chạy gần đúng rồi, chỉ là chưa lấy đúng hệ số nhãn hiệu thôi mà em không biết chỉnh chổ nào cho đúng.

leonguyenz · 8/9/15

Tôi sửa lại một chút theo code của bạn:

Mã:

Public Sub heso()
Dim Dic As Object, Rng As Range, Cll As Range ', SCll As Range
Dim k As Integer, TmpArr()
Set Dic = CreateObject("Scripting.Dictionary")
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .EnableEvents = False
End With
Set Rng = Sheet2.Range("D21:D25")
ReDim TmpArr(1 To Rng.Rows.Count, 1 To 2)
For Each Cll In Rng
'Set SCll = Cll.Offset(, 1)
    If Cll.Value <> vbNullString Then 'And SCll.Value <> vbNullString Then
     'Set SCll = Cll.Offset(, 1)
        If Not Dic.exists(Cll.Value) Then
            k = k + 1
            Dic.Add Cll.Value, k
            TmpArr(k, 1) = Cll.Value
            TmpArr(k, 2) = Cll.Offset(, 1).Value
        End If
    End If
Next
With Sheet1
    Set Rng = .Range(.[F11], .[F15000].End(xlUp))
    For Each Cll In Rng
        If Cll.Offset(, 7) > 0 Then
            If Dic.exists(Cll.Value) Then
                Cll.Offset(, 10).Value = Cll.Offset(, 7).Value / TmpArr(Dic.Item(Cll.Value), 2)
                Cll.Offset(, 11).Value = Cll.Offset(, 10).Value - Cll.Offset(, 7).Value
            End If
        Else
            Cll.Offset(, 7).Value = vbNullString
        End If
    Next
End With
Set Dic = Nothing
Set Rng = Nothing
With Application
.Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .EnableEvents = True
End With
End Sub

Ba Tê · 8/9/15

ketoanvien1985 đã viết:
Nhờ anh chị xem code này giúp em với ạ, nó chạy gần đúng rồi, chỉ là chưa lấy đúng hệ số nhãn hiệu thôi mà em không biết chỉnh chổ nào cho đúng.

Thà bạn nhập kết quả bằng tay, nói rõ cách tính, còn dễ hơn đọc code.
Bạn nói code chạy sai làm sao biết được đúng thì ra cái gì?
Theo giải thích của bạn thì chạy code này xem sao:

PHP:

Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet2
    sArr = .Range(.[D20], .[D20].End(xlDown)).Resize(, 2).Value
End With
For I = 2 To UBound(sArr, 1)
    Tem = UCase(sArr(I, 1))
    Dic.Item(Tem) = sArr(I, 2)
Next I
With Sheet1
    sArr = .Range(.[F11], .[F11].End(xlDown)).Resize(, 8).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = UCase(sArr(I, 1))
        If Dic.Exists(Tem) Then
            dArr(I, 1) = sArr(I, 8) / Dic.Item(Tem)
            dArr(I, 2) = dArr(I, 1) - sArr(I, 8)
            dArr(I, 3) = dArr(I, 2) * sArr(I, 3)
        End If
    Next I
    .[P11].Resize(I - 1, 3) = dArr
End With
Set Dic = Nothing
End Sub

Nếu sửa code của bạn theo cách hiểu như trên thì nó thế này:

PHP:

Public Sub heso()
Dim Dic As Object, Rng As Range, Cll As Range
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheet2.Range("D21:D25")
For Each Cll In Rng
    If Cll.Value <> vbNullString Then
        If Not Dic.exists(Cll.Value) Then Dic.Add Cll.Value, Cll.Offset(, 1).Value
    End If
Next
With Sheet1
    Set Rng = .Range(.[F11], .[F15000].End(xlUp))
    For Each Cll In Rng
        If Cll.Offset(, 7) > 0 Then
            If Dic.exists(Cll.Value) Then
                Cll.Offset(, 10).Value = Cll.Offset(, 7).Value / Dic.Item(Cll.Value)
                Cll.Offset(, 11).Value = Cll.Offset(, 10).Value - Cll.Offset(, 7).Value
            End If
        Else
            Cll.Offset(, 7).Value = vbNullString
        End If
    Next
End With
Set Dic = Nothing
Set Rng = Nothing
End Sub

ketoanvien1985 · 8/9/15

leonguyenz đã viết:

Tôi sửa lại một chút theo code của bạn:

Mã:

Public Sub heso()
Dim Dic As Object, Rng As Range, Cll As Range ', SCll As Range
Dim k As Integer, TmpArr()
Set Dic = CreateObject("Scripting.Dictionary")
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .EnableEvents = False
End With
Set Rng = Sheet2.Range("D21:D25")
ReDim TmpArr(1 To Rng.Rows.Count, 1 To 2)
For Each Cll In Rng
'Set SCll = Cll.Offset(, 1)
    If Cll.Value <> vbNullString Then 'And SCll.Value <> vbNullString Then
     'Set SCll = Cll.Offset(, 1)
        If Not Dic.exists(Cll.Value) Then
            k = k + 1
            Dic.Add Cll.Value, k
            TmpArr(k, 1) = Cll.Value
            TmpArr(k, 2) = Cll.Offset(, 1).Value
        End If
    End If
Next
With Sheet1
    Set Rng = .Range(.[F11], .[F15000].End(xlUp))
    For Each Cll In Rng
        If Cll.Offset(, 7) > 0 Then
            If Dic.exists(Cll.Value) Then
                Cll.Offset(, 10).Value = Cll.Offset(, 7).Value / TmpArr(Dic.Item(Cll.Value), 2)
                Cll.Offset(, 11).Value = Cll.Offset(, 10).Value - Cll.Offset(, 7).Value
            End If
        Else
            Cll.Offset(, 7).Value = vbNullString
        End If
    Next
End With
Set Dic = Nothing
Set Rng = Nothing
With Application
.Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .EnableEvents = True
End With
End Sub

Code của anh chạy ok rồi ạ, Cảm ơn anh rất nhiều. }}}}}

ketoanvien1985 · 8/9/15

Ba Tê đã viết:

Thà bạn nhập kết quả bằng tay, nói rõ cách tính, còn dễ hơn đọc code.
Bạn nói code chạy sai làm sao biết được đúng thì ra cái gì?
Theo giải thích của bạn thì chạy code này xem sao:

PHP:

Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet2
    sArr = .Range(.[D20], .[D20].End(xlDown)).Resize(, 2).Value
End With
For I = 2 To UBound(sArr, 1)
    Tem = UCase(sArr(I, 1))
    Dic.Item(Tem) = sArr(I, 2)
Next I
With Sheet1
    sArr = .Range(.[F11], .[F11].End(xlDown)).Resize(, 8).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = UCase(sArr(I, 1))
        If Dic.Exists(Tem) Then
            dArr(I, 1) = sArr(I, 8) / Dic.Item(Tem)
            dArr(I, 2) = dArr(I, 1) - sArr(I, 8)
            dArr(I, 3) = dArr(I, 2) * sArr(I, 3)
        End If
    Next I
    .[P11].Resize(I - 1, 3) = dArr
End With
Set Dic = Nothing
End Sub

Cảm ơn anh Ba Tê, Vì em có up file nên để các anh chạy thử sẽ hiểu, em sợ nói ra mong lung quá lại càng rối, tình hình là em nhập 3 nhãn hiệu, 3 hệ số thì nó chỉ lấy cái hệ số cuối cùng rồi tính cho tất cả, nó ko nhận biết được 2 hệ số kia. -+*/

leonguyenz · 8/9/15

Ngoài việc lấy hệ số như trong file, nếu không tính toán thêm gì thì nên dùng hàm có sẵn (VLOOKUP, INDEX) để dò tìm hệ số. Nếu sử dụng code, có thể tham khảo phương thức Find.

ketoanvien1985 · 8/9/15

Ba Tê đã viết:

Thà bạn nhập kết quả bằng tay, nói rõ cách tính, còn dễ hơn đọc code.
Bạn nói code chạy sai làm sao biết được đúng thì ra cái gì?
Theo giải thích của bạn thì chạy code này xem sao:

PHP:

Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet2
    sArr = .Range(.[D20], .[D20].End(xlDown)).Resize(, 2).Value
End With
For I = 2 To UBound(sArr, 1)
    Tem = UCase(sArr(I, 1))
    Dic.Item(Tem) = sArr(I, 2)
Next I
With Sheet1
    sArr = .Range(.[F11], .[F11].End(xlDown)).Resize(, 8).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = UCase(sArr(I, 1))
        If Dic.Exists(Tem) Then
            dArr(I, 1) = sArr(I, 8) / Dic.Item(Tem)
            dArr(I, 2) = dArr(I, 1) - sArr(I, 8)
            dArr(I, 3) = dArr(I, 2) * sArr(I, 3)
        End If
    Next I
    .[P11].Resize(I - 1, 3) = dArr
End With
Set Dic = Nothing
End Sub

Nếu sửa code của bạn theo cách hiểu như trên thì nó thế này:

PHP:

Public Sub heso()
Dim Dic As Object, Rng As Range, Cll As Range
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheet2.Range("D21:D25")
For Each Cll In Rng
    If Cll.Value <> vbNullString Then
        If Not Dic.exists(Cll.Value) Then Dic.Add Cll.Value, Cll.Offset(, 1).Value
    End If
Next
With Sheet1
    Set Rng = .Range(.[F11], .[F15000].End(xlUp))
    For Each Cll In Rng
        If Cll.Offset(, 7) > 0 Then
            If Dic.exists(Cll.Value) Then
                Cll.Offset(, 10).Value = Cll.Offset(, 7).Value / Dic.Item(Cll.Value)
                Cll.Offset(, 11).Value = Cll.Offset(, 10).Value - Cll.Offset(, 7).Value
            End If
        Else
            Cll.Offset(, 7).Value = vbNullString
        End If
    Next
End With
Set Dic = Nothing
Set Rng = Nothing
End Sub

Code này của anh Ba Tê cũng chạy ok luôn, Cảm ơn anh nhiều nha.

ronlb · 9/9/15

Xong nhé, k cầu kì phức tạp

Tính giá sản phẩm theo từng hệ số cho trước (1 người xem)

Người dùng đang xem chủ đề này

ketoanvien1985

Thành viên mới

File đính kèm

ketoanvien1985

Thành viên mới

leonguyenz

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

File đính kèm

Ba Tê

Cạo Rồi Khỏi Gội

ketoanvien1985

Thành viên mới

ketoanvien1985

Thành viên mới

leonguyenz

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

ketoanvien1985

Thành viên mới

ronlb

Thành viên mới

File đính kèm

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

Đếm ngược thời gian