[Hỗ trợ code] tính toán trên excel

Mai.Vũ · 3/7/19

Các anh chị có kinh nghiệm viết code trên Excel có thể giúp em viết code cho bài tính này được không ạ.
Có sẵn 2 cột giá trị là cột thời gian "Time" và cột mã "ZIG" trong một ngày. Sau đó tính các "khoảng cách tuyệt đối", "khoảng cách tương đối" và "độ dốc" dựa trên 2 cột này.
1. Với khoảng cách tuyệt đối (Absolute distance) tính X, Y, L:
X_t = sqrt(n) , trong đó: n là số phút cho đến điểm uốn trong cột ZIG tiếp theo. Ví dụ: đa tuyết ZIG đầu tiên biểu thị cho khoảng thời gian t : 9:30~9:36 => n= 6.
Y_t = ZIG_(t+1) - ZIG_(t)
L_t = sqrt( X*X + Y*Y)
2. Với khoảng cách tương đối (relative distance) tính RX, RY, RY và Slope:
RX_(t) = X_(t) / X_(t-1);
RY_(t) = Y_(t) / Y_(t-1);
RL_(t) = L_(t) / L_(t-1);
Slope_(t) = X_(t) / Y_(t)

Các tính toán này em đều đã tính thử trong excel " Tính độ dốc", nhưng tính toán bằng tay thì quá lâu và dài.
Em cám ơn ạ!

Mai.Vũ · 4/7/19

HeSanbi · 4/7/19

Code dưới tôi chỉ viết theo cách đơn giản, không có thuật giải gì hay cả, bạn dùng thử xem.
Tuổi trẻ nên bạn cần học tập thêm tính kĩ lưỡng, cái ví dụ của bạn thiếu tính triệt để và nhất quán để người khác có thể dể giúp bạn hơn.

PHP:

Option Explicit
Sub ZigLine()
  Dim Arr, UB&, Rng As Range, Back As Boolean
  Dim R&, nR&, sZIG&
  With ThisWorkbook.Worksheets(1)
    Set Rng = .[A3]
    Arr = .Range(Rng, .Cells(Rows.Count, Rng.Column).End(xlUp)).Resize(, 3).Value2
  End With
  UB = UBound(Arr)
  ReDim Total(1 To UB, 1 To 7)
  For R = 1 To UB
    Total(R, 1) = Arr(R, 3) ^ 0.5
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        Dim tY
        tY = Abs(Arr(R, 2) - Arr(sZIG, 2))
        For nR = sZIG To R - 1
          Total(nR, 2) = tY
          Total(nR, 3) = ((tY ^ 2) + (Total(nR, 1) ^ 2)) ^ 0.5
          Total(nR, 7) = tY / Total(nR, 1)
        Next
        sZIG = R
      End If
    End If
  Next
  sZIG& = 0: lZIG& = 0: nZIG& = 0
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        For nR = R To UB - 1
          If nR > R And Arr(nR, 2) <> vbNullString Then Exit For
          Total(nR, 4) = Total(R, 1) / Total(sZIG, 1)
          Total(nR, 5) = Total(R, 2) / Total(sZIG, 2)
          Total(nR, 6) = Total(R, 3) / Total(sZIG, 3)
        Next
        sZIG = R
      End If
    End If
  Next
  Rng(1, 4).Resize(UB, 7).Value = Total
  Set Rng = Nothing
End Sub

Mai.Vũ · 5/7/19

HeSanbi đã viết:

Code dưới tôi chỉ viết theo cách đơn giản, không có thuật giải gì hay cả, bạn dùng thử xem.
Tuổi trẻ nên bạn cần học tập thêm tính kĩ lưỡng, cái ví dụ của bạn thiếu tính triệt để và nhất quán để người khác có thể dể giúp bạn hơn.

PHP:

Option Explicit
Sub ZigLine()
  Dim Arr, UB&, Rng As Range, Back As Boolean
  Dim R&, nR&, sZIG&
  With ThisWorkbook.Worksheets(1)
    Set Rng = .[A3]
    Arr = .Range(Rng, .Cells(Rows.Count, Rng.Column).End(xlUp)).Resize(, 3).Value2
  End With
  UB = UBound(Arr)
  ReDim Total(1 To UB, 1 To 7)
  For R = 1 To UB
    Total(R, 1) = Arr(R, 3) ^ 0.5
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        Dim tY
        tY = Abs(Arr(R, 2) - Arr(sZIG, 2))
        For nR = sZIG To R - 1
          Total(nR, 2) = tY
          Total(nR, 3) = ((tY ^ 2) + (Total(nR, 1) ^ 2)) ^ 0.5
          Total(nR, 7) = tY / Total(nR, 1)
        Next
        sZIG = R
      End If
    End If
  Next
  sZIG& = 0: lZIG& = 0: nZIG& = 0
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        For nR = R To UB - 1
          If nR > R And Arr(nR, 2) <> vbNullString Then Exit For
          Total(nR, 4) = Total(R, 1) / Total(sZIG, 1)
          Total(nR, 5) = Total(R, 2) / Total(sZIG, 2)
          Total(nR, 6) = Total(R, 3) / Total(sZIG, 3)
        Next
        sZIG = R
      End If
    End If
  Next
  Rng(1, 4).Resize(UB, 7).Value = Total
  Set Rng = Nothing
End Sub

Em cám ơn ạ, nếu lần sau có vấn đề, em sẽ cố gắng show rõ ràng hơn.

Mai.Vũ · 5/7/19

HeSanbi đã viết:

Code dưới tôi chỉ viết theo cách đơn giản, không có thuật giải gì hay cả, bạn dùng thử xem.
Tuổi trẻ nên bạn cần học tập thêm tính kĩ lưỡng, cái ví dụ của bạn thiếu tính triệt để và nhất quán để người khác có thể dể giúp bạn hơn.

PHP:

Option Explicit
Sub ZigLine()
  Dim Arr, UB&, Rng As Range, Back As Boolean
  Dim R&, nR&, sZIG&
  With ThisWorkbook.Worksheets(1)
    Set Rng = .[A3]
    Arr = .Range(Rng, .Cells(Rows.Count, Rng.Column).End(xlUp)).Resize(, 3).Value2
  End With
  UB = UBound(Arr)
  ReDim Total(1 To UB, 1 To 7)
  For R = 1 To UB
    Total(R, 1) = Arr(R, 3) ^ 0.5
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        Dim tY
        tY = Abs(Arr(R, 2) - Arr(sZIG, 2))
        For nR = sZIG To R - 1
          Total(nR, 2) = tY
          Total(nR, 3) = ((tY ^ 2) + (Total(nR, 1) ^ 2)) ^ 0.5
          Total(nR, 7) = tY / Total(nR, 1)
        Next
        sZIG = R
      End If
    End If
  Next
  sZIG& = 0: lZIG& = 0: nZIG& = 0
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        For nR = R To UB - 1
          If nR > R And Arr(nR, 2) <> vbNullString Then Exit For
          Total(nR, 4) = Total(R, 1) / Total(sZIG, 1)
          Total(nR, 5) = Total(R, 2) / Total(sZIG, 2)
          Total(nR, 6) = Total(R, 3) / Total(sZIG, 3)
        Next
        sZIG = R
      End If
    End If
  Next
  Rng(1, 4).Resize(UB, 7).Value = Total
  Set Rng = Nothing
End Sub

Em tham khảo gợi ý của anh thì thấy code có bị lỗi chia cho 0 ạ.
Em không biết dùng cách gì trên VBA để sửa lỗi này vì em không làm việc trên này bao giờ ạ, nên có chút khó khăn.
Anh có thể giúp em sửa lỗi này và chạy thử với file số liệu "Tính độ dốc.xls" được không ạ?
Em rất cám ơn anh ạ

HeSanbi · 5/7/19

Cách diễn đạt của bạn cũng căng thật.

Dòng cuối sẽ không đủ điều kiện để tính nhé bạn.

PHP:

Option Explicit
Sub ZigLine()
  Dim Arr, UB&, Rng As Range, Back As Boolean
  Dim R&, nR&, sZIG&, K&
  With ThisWorkbook.Worksheets(1)
    Set Rng = .[A3]
    Arr = .Range(Rng, .Cells(Rows.Count, Rng.Column).End(xlUp)).Resize(, 3).Value2
  End With
  UB = UBound(Arr)
  ReDim Total(1 To UB, 1 To 8)
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        Dim tY
        tY = Abs(Arr(R, 2) - Arr(sZIG, 2))
        K = R - sZIG
        For nR = sZIG To R - 1
          Total(nR, 2) = K ^ 0.5
          Total(nR, 3) = tY
          Total(nR, 4) = ((tY ^ 2) + (Total(nR, 2) ^ 2)) ^ 0.5
          Total(nR, 8) = tY / Total(nR, 2)
        Next
        Total(sZIG, 1) = K
        sZIG = R
      End If
    End If
  Next
  sZIG& = 0
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        For nR = R To UB - 1
          If nR > R And Arr(nR, 2) <> vbNullString Then Exit For
          Total(nR, 5) = Total(R, 2) / Total(sZIG, 2)
          Total(nR, 6) = Total(R, 3) / Total(sZIG, 3)
          Total(nR, 7) = Total(R, 4) / Total(sZIG, 4)
        Next
        sZIG = R
      End If
    End If
  Next
  Rng(1, 3).Resize(UB, 8).Value = Total
  Set Rng = Nothing
End Sub

Mai.Vũ · 5/7/19

HeSanbi đã viết:

Cách diễn đạt của bạn cũng căng thật.

Dòng cuối sẽ không đủ điều kiện để tính nhé bạn.

PHP:

Option Explicit
Sub ZigLine()
  Dim Arr, UB&, Rng As Range, Back As Boolean
  Dim R&, nR&, sZIG&, K&
  With ThisWorkbook.Worksheets(1)
    Set Rng = .[A3]
    Arr = .Range(Rng, .Cells(Rows.Count, Rng.Column).End(xlUp)).Resize(, 3).Value2
  End With
  UB = UBound(Arr)
  ReDim Total(1 To UB, 1 To 8)
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        Dim tY
        tY = Abs(Arr(R, 2) - Arr(sZIG, 2))
        K = R - sZIG
        For nR = sZIG To R - 1
          Total(nR, 2) = K ^ 0.5
          Total(nR, 3) = tY
          Total(nR, 4) = ((tY ^ 2) + (Total(nR, 2) ^ 2)) ^ 0.5
          Total(nR, 8) = tY / Total(nR, 2)
        Next
        Total(sZIG, 1) = K
        sZIG = R
      End If
    End If
  Next
  sZIG& = 0
  For R = 1 To UB
    If R = 1 Then
      sZIG = 1
    Else
      If Arr(R, 2) <> vbNullString Then
        For nR = R To UB - 1
          If nR > R And Arr(nR, 2) <> vbNullString Then Exit For
          Total(nR, 5) = Total(R, 2) / Total(sZIG, 2)
          Total(nR, 6) = Total(R, 3) / Total(sZIG, 3)
          Total(nR, 7) = Total(R, 4) / Total(sZIG, 4)
        Next
        sZIG = R
      End If
    End If
  Next
  Rng(1, 3).Resize(UB, 8).Value = Total
  Set Rng = Nothing
End Sub

Em cám ơn anh rất nhiều ạ

[Hỗ trợ code] tính toán trên excel

Mai.Vũ

Thành viên mới

File đính kèm

Mai.Vũ

Thành viên mới

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Mai.Vũ

Thành viên mới

Mai.Vũ

Thành viên mới

File đính kèm

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Mai.Vũ

Thành viên mới

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