Giúp code tính thành tiền từ 1 chuỗi dữ liệu (1 người xem)

[minhtuan55]

Chào cả nhà GPE ! Em cần 1 đoạn code để tính thành tiền. mà em dùng hàm Vlookup không được. mong cả nhà dùng Code em bấm cái Xẹt là ra liền. em xin chân thành cảm ơn

 

[TheThienChu]

Chào cả nhà GPE ! Em cần 1 đoạn code để tính thành tiền. mà em dùng hàm Vlookup không được. mong cả nhà dùng Code em bấm cái Xẹt là ra liền. em xin chân thành cảm ơn

Chép đoạn code này vào modul
Nhấn alt + F8 để chạy

Sub TinhTien()
Dim SArr(), Res, Temp
Dim Cnd, i, j, k

SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
Cnd = Sheet1.Range("F1:J17")
ReDim Res(1 To UBound(SArr), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Cnd) Step 6
    For j = i + 2 To i + 4
    .Add Cnd(i, 1) & " " & Cnd(j, 1), Array(Cnd(j, 2), Cnd(j, 3), Cnd(j, 4), Cnd(j, 5))
    Next j
Next i
For i = 1 To UBound(SArr)
    Temp = Split(WorksheetFunction.Trim(Replace(Replace(SArr(i, 1), ":", " "), ";", " ")), " ")
    For j = 2 To UBound(Temp)
        If .exists(Temp(0) & " " & Temp(j)) Then
        k = k + Val(.Item(Temp(0) & " " & Temp(j))(CLng(Right(Temp(j - 1), 1)) - 1))
        End If
    Next j
    Res(i, 1) = k
    k = 0
Next i
End With
Sheet1.Range("C2", "C" & UBound(Res) + 1).ClearContents
Sheet1.Range("C2", "C" & UBound(Res) + 1) = Res
End Sub

(Còn thiếu trường hợp "kém" hay sao í )

 

[minhtuan55]

Em cảm ơn anh nhiều lắm anh làm đúng gần 95 % rồi . Lúc nảy Em gửi lại file bị thiếu. Giờ em gửi lại anh sữa lại hoàn chỉnh giúp em.

Chép đoạn code này vào modul
Nhấn alt + F8 để chạy

Sub TinhTien()
Dim SArr(), Res, Temp
Dim Cnd, i, j, k

SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
Cnd = Sheet1.Range("F1:J17")
ReDim Res(1 To UBound(SArr), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Cnd) Step 6
    For j = i + 2 To i + 4
    .Add Cnd(i, 1) & " " & Cnd(j, 1), Array(Cnd(j, 2), Cnd(j, 3), Cnd(j, 4), Cnd(j, 5))
    Next j
Next i
For i = 1 To UBound(SArr)
    Temp = Split(WorksheetFunction.Trim(Replace(Replace(SArr(i, 1), ":", " "), ";", " ")), " ")
    For j = 2 To UBound(Temp)
        If .exists(Temp(0) & " " & Temp(j)) Then
        k = k + Val(.Item(Temp(0) & " " & Temp(j))(CLng(Right(Temp(j - 1), 1)) - 1))
        End If
    Next j
    Res(i, 1) = k
    k = 0
Next i
End With
Sheet1.Range("C2", "C" & UBound(Res) + 1).ClearContents
Sheet1.Range("C2", "C" & UBound(Res) + 1) = Res
End Sub

(Còn thiếu trường hợp "kém" hay sao í )

 

[TheThienChu]

Em cảm ơn anh nhiều lắm anh làm đúng gần 95 % rồi . Lúc nảy Em gửi lại file bị thiếu. Giờ em gửi lại anh sữa lại hoàn chỉnh giúp em.

Chắc là gần hơn 95%

Sub TinhTien()
Dim SArr(), Res, Temp
Dim Cnd, i, j, k

SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
Cnd = Sheet1.Range("G3", Sheet1.Range("L3").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Cnd)
    .Add Cnd(i, 1) & " " & Cnd(i, 2), Array(Cnd(i, 3), Cnd(i, 4), Cnd(i, 5), Cnd(i, 6))
Next i
For i = 1 To UBound(SArr)
    Temp = Split(WorksheetFunction.Trim(Replace(Replace(SArr(i, 1), ":", " "), ";", " ")), " ")
    For j = 2 To UBound(Temp)
        If .exists(Temp(0) & " " & Temp(j)) Then
        k = k + Val(.Item(Temp(0) & " " & Temp(j))(CLng(Right(Temp(j - 1), 1)) - 1))
        End If
    Next j
    Res(i, 1) = k
    k = 0
Next i
End With
Sheet1.Range("C2", "C" & UBound(Res) + 1).ClearContents
Sheet1.Range("C2", "C" & UBound(Res) + 1) = Res
End Sub

 

[HieuCD]

chạy thử code

Sub GPE()
Dim Darr(), Sarr(), Dic As Object, Tmp As String, S, i As Long, j As Byte
Darr = Range("G2:L" & Range("G2").End(xlDown).Row).Value
Range("C2:C" & Range("B2").End(xlDown).Row).ClearContents
Sarr = Range("B2:C" & Range("B2").End(xlDown).Row).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Darr)
    For j = 3 To 6
      Tmp = Darr(i, 1) & "#" & Darr(i, 2) & "#" & Darr(1, j)
      Dic.Add Tmp, Darr(i, j)
    Next j
Next i
For i = 1 To UBound(Sarr)
    S = Split(WorksheetFunction.Trim(Replace(Replace(Sarr(i, 1), ":", " "), ";", " ")), " ")
    For j = 1 To UBound(S) Step 2
        Tmp = S(0) & "#" & S(j + 1) & "#" & S(j)
        If Dic.exists(Tmp) Then
          Sarr(i, 2) = Sarr(i, 2) + Dic.Item(Tmp)
        End If
    Next j
Next i
Range("B2").Resize(UBound(Sarr), 2) = Sarr
Set Dic = Nothing
End Sub

 

[minhtuan55]

Không còn gì để nói. Quá chính xác tuyệt đối anh nhé. Ak mà còn thiếu phần Reset Ouput em tự thêm vào rồi ( Tránh trường hợp dử liệu đang dài rồi ngắn lại )

Sub TinhTien()
[COLOR=#ff0000]Range("C2:C501").ClearContents[/COLOR]
Dim SArr(), Res, Temp
Dim Cnd, i, j, k


SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
Cnd = Sheet1.Range("G3", Sheet1.Range("L3").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Cnd)
    .Add Cnd(i, 1) & " " & Cnd(i, 2), Array(Cnd(i, 3), Cnd(i, 4), Cnd(i, 5), Cnd(i, 6))
Next i
For i = 1 To UBound(SArr)
    Temp = Split(WorksheetFunction.Trim(Replace(Replace(SArr(i, 1), ":", " "), ";", " ")), " ")
    For j = 2 To UBound(Temp)
        If .exists(Temp(0) & " " & Temp(j)) Then
        k = k + Val(.Item(Temp(0) & " " & Temp(j))(CLng(Right(Temp(j - 1), 1)) - 1))
        End If
    Next j
    Res(i, 1) = k
    k = 0
Next i
End With
Sheet1.Range("C2", "C" & UBound(Res) + 1).ClearContents
Sheet1.Range("C2", "C" & UBound(Res) + 1) = Res
End Sub

Chắc là gần hơn 95%

Sub TinhTien()
Dim SArr(), Res, Temp
Dim Cnd, i, j, k

SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
Cnd = Sheet1.Range("G3", Sheet1.Range("L3").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Cnd)
    .Add Cnd(i, 1) & " " & Cnd(i, 2), Array(Cnd(i, 3), Cnd(i, 4), Cnd(i, 5), Cnd(i, 6))
Next i
For i = 1 To UBound(SArr)
    Temp = Split(WorksheetFunction.Trim(Replace(Replace(SArr(i, 1), ":", " "), ";", " ")), " ")
    For j = 2 To UBound(Temp)
        If .exists(Temp(0) & " " & Temp(j)) Then
        k = k + Val(.Item(Temp(0) & " " & Temp(j))(CLng(Right(Temp(j - 1), 1)) - 1))
        End If
    Next j
    Res(i, 1) = k
    k = 0
Next i
End With
Sheet1.Range("C2", "C" & UBound(Res) + 1).ClearContents
Sheet1.Range("C2", "C" & UBound(Res) + 1) = Res
End Sub