Kết quả 1 đến 6 của 6

Chủ đề: Code tính diễn giải khối lượng ở nhiều cột

  1. #1
    thetranvanminh Guest

  2. #2
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Trích dẫn Gửi bởi zerocoldtn
    - Làm sao để ra như hình trên, các AC trên GPE có code nào như vậy giúp em nha!
    bạn xem bài này có xài được không
    http://www.giaiphapexcel.com/forum/s...550#post722550

  3. #3
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Trích dẫn Gửi bởi Let'GâuGâu
    bạn xem bài này có xài được không
    http://www.giaiphapexcel.com/forum/s...550#post722550
    Em thấy 2 bài đăng có vẻ là của cùng 1 người. hic

  4. #4
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Links của anh là tính tổng, cái em cần là tính từng phần ở nhiều ô (cell) như hình, và công thức sử dụng dấu "x" làm dấu nhân, các a giúp e nha!

  5. #5
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Trích dẫn Gửi bởi zerocoldtn
    Links của anh là tính tổng, cái em cần là tính từng phần ở nhiều ô (cell) như hình, và công thức sử dụng dấu "x" làm dấu nhân, các a giúp e nha!
    Trong link của anh Let'GâuGâu đã có cách tính theo yêu cầu cảu bạn rùi nhé.(bài #6)
    Mình góp thêm 1 ít code theo cách của mình:
    sử dụng Function

    Mã:
    Function ValueEval(rng As String)
    Dim i As Integer
    Dim strTemp As String
    For i = 1 To Len(rng)
        Select Case Asc(Mid(rng, i, 1))
        Case 40 To 45, 47 To 58, 91, 93, 120, 123, 125
            ValueEval = ValueEval & Mid(rng, i, 1)
        End Select
    Next i
    strTemp = Replace(ValueEval, "x", "*")
    strTemp = Replace(strTemp, ":", "/")
    strTemp = Replace(strTemp, "{", "(")
    strTemp = Replace(strTemp, "}", ")")
    strTemp = Replace(strTemp, "[", "(")
    strTemp = Replace(strTemp, "]", ")")
    strTemp = Replace(strTemp, ",", ".")
    ValueEval = Evaluate(strTemp)
    End Function
    Chạy sub sau

    Mã:
    Sub run()
    Dim i, pos As Integer, xau As String
    For i = 8 To 23
    If Cells(i, 4) = "" Then
        If Cells(i, 5) <> "" Then
            pos = InStr(1, Cells(i, 5), ":")
            xau = Mid(Cells(i, 5), pos + 1, Len(Cells(i, 5)))
            xau = ValueEval(xau)
            Cells(i, 5) = Cells(i, 5) & " = " & xau
        End If
        If Cells(i, 62) <> "" Then
            pos = InStr(1, Cells(i, 62), ":")
            xau = Mid(Cells(i, 62), pos + 1, Len(Cells(i, 62)))
            xau = ValueEval(xau)
            Cells(i, 62) = Cells(i, 62) & " = " & xau
        End If
    End If
    Next
    End Sub

  6. #6
    bomhao Guest
    Cám ơn các Ac trên GPE, em đã có thứ mình cần, gửi lại code để có ai cần giống mình thì tham khảo nhé!
    Code sheet tính kl như DT ở nhiều cột (muốn ở cột nào thì sửa lại ở cột đó, ở đây là cột e, bj, bl):


    Private Function FormatWithComma(ByVal number As Double) As String
    Dim text As String, result As String
    text = Format(2001 / 2, "#,##0.0")
    result = Format(number, "#,##0.0##")
    If Mid(text, 6, 1) = "," Then
    FormatWithComma = Replace(result, Mid(text, 2, 1), ".")
    Else
    result = Replace(result, ".", "@")
    result = Replace(result, Mid(text, 2, 1), ".")
    FormatWithComma = Replace(result, "@", ",")
    End If
    End Function


    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim expression, ketqua, bieuthuc As String, result, result2 As Double
    If Not Intersect(Target, Range("e1:e10000")) Is Nothing Then
    If Target.Count = 1 Then
    If Target.Value <> "" Then
    If InStr(Target, "=") > 0 Then
    ketqua = Trim(Split(Target.Value, "=")(1))
    bieuthuc = Trim(Split(Target.Value, "=")(0))
    Else: bieuthuc = Target.Value
    End If
    If InStr(Target, ":") > 0 Then
    'expression = Trim(Split(Target.Value, ":")(1))
    expression = Trim(Split(bieuthuc, ":")(1))
    Else
    'expression = Trim(Target.Value)
    expression = Trim(bieuthuc)
    End If
    expression = Replace(expression, ",", ".")
    expression = Replace(expression, "x", "*")
    Application.EnableEvents = False
    On Error Resume Next
    result = Evaluate(expression)
    On Error Resume Next
    result2 = Evaluate(ketqua)
    If result = 0 Then
    If result2 <> 0 Then
    Target.Value = "'" & Trim(bieuthuc)
    End If
    Else
    Target.Value = "'" & Trim(bieuthuc) & " = " & FormatWithComma(result)
    Target.Characters(1, InStr(Target, "=")).Font.Color = xlThemeColorLight2
    Target.Characters(InStr(Target, "=") + 1).Font.Color = -16776961
    End If
    End If
    End If
    End If
    end_:
    Application.EnableEvents = True


    If Not Intersect(Target, Range("bj1:bj10000")) Is Nothing Then
    If Target.Count = 1 Then
    If Target.Value <> "" Then
    If InStr(Target, "=") > 0 Then
    ketqua = Trim(Split(Target.Value, "=")(1))
    bieuthuc = Trim(Split(Target.Value, "=")(0))
    Else: bieuthuc = Target.Value
    End If
    If InStr(Target, ":") > 0 Then
    'expression = Trim(Split(Target.Value, ":")(1))
    expression = Trim(Split(bieuthuc, ":")(1))
    Else
    'expression = Trim(Target.Value)
    expression = Trim(bieuthuc)
    End If
    expression = Replace(expression, ",", ".")
    expression = Replace(expression, "x", "*")
    Application.EnableEvents = False
    On Error Resume Next
    result = Evaluate(expression)
    On Error Resume Next
    result2 = Evaluate(ketqua)
    If result = 0 Then
    If result2 <> 0 Then
    Target.Value = "'" & Trim(bieuthuc)
    End If
    Else
    Target.Value = "'" & Trim(bieuthuc) & " = " & FormatWithComma(result)
    Target.Characters(1, InStr(Target, "=")).Font.Color = xlThemeColorLight2
    Target.Characters(InStr(Target, "=") + 1).Font.Color = -16776961
    End If
    End If
    End If
    End If
    Application.EnableEvents = True


    If Not Intersect(Target, Range("bl1:bl10000")) Is Nothing Then
    If Target.Count = 1 Then
    If Target.Value <> "" Then
    If InStr(Target, "=") > 0 Then
    ketqua = Trim(Split(Target.Value, "=")(1))
    bieuthuc = Trim(Split(Target.Value, "=")(0))
    Else: bieuthuc = Target.Value
    End If
    If InStr(Target, ":") > 0 Then
    'expression = Trim(Split(Target.Value, ":")(1))
    expression = Trim(Split(bieuthuc, ":")(1))
    Else
    'expression = Trim(Target.Value)
    expression = Trim(bieuthuc)
    End If
    expression = Replace(expression, ",", ".")
    expression = Replace(expression, "x", "*")
    Application.EnableEvents = False
    On Error Resume Next
    result = Evaluate(expression)
    On Error Resume Next
    result2 = Evaluate(ketqua)
    If result = 0 Then
    If result2 <> 0 Then
    Target.Value = "'" & Trim(bieuthuc)
    End If
    Else
    Target.Value = "'" & Trim(bieuthuc) & " = " & FormatWithComma(result)
    Target.Characters(1, InStr(Target, "=")).Font.Color = xlThemeColorLight2
    Target.Characters(InStr(Target, "=") + 1).Font.Color = -16776961
    End If
    End If
    End If
    End If
    Application.EnableEvents = True
    End Sub

    Code tính Tổng KL ở modul:

    Function TongKL(sRg As Range) As Double
    For Each Cell In sRg
    If IsNumeric(Right(Cell.Value, 1)) And InStr(Cell, "=") Then
    KL = Right(Cell.Value, Len(Cell.Value) - InStr(Cell.Value, "=") - 1)
    TongKL = TongKL + KL
    End If
    Next
    End Function

Quyền viết bài

  • Bạn Không thể gửi Chủ đề mới
  • Bạn Không thể Gửi trả lời
  • Bạn Không thể Gửi file đính kèm
  • Bạn Không thể Sửa bài viết của mình
  •