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

Liên hệ QC
Mai.Vũ

Mai.Vũ

Thành viên mới
Tham gia
21/6/19
Bài viết
22
Được thích
1
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 ạ!
 

File đính kèm

  • Ảnh_absolute.PNG
    Ảnh_absolute.PNG
    19 KB · Đọc: 15
  • Tính độ dốc.xls
    100 KB · Đọc: 10
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Em cám ơn ạ, nếu lần sau có vấn đề, em sẽ cố gắng show rõ ràng hơn.
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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 ạ
 

File đính kèm

  • Anh_Error_1.png
    Anh_Error_1.png
    49.6 KB · Đọc: 15
  • Ảnh_2.png
    Ảnh_2.png
    84.4 KB · Đọc: 14
  • Ảnh_error.PNG
    Ảnh_error.PNG
    12.8 KB · Đọc: 14
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh rất nhiều ạ :D
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

tamnt07
Hàm thể hiện ngày tháng bị sai?
    • Cười
Trả lời
8
Đọc
158
hoangtuan.net
hoangtuan.net
A
Tách 1 sheet thành nhiều sheet theo điều kiện
2
Trả lời
21
Đọc
4K
ttsuong
T
N
Hàm If và Index trong Excel?
Trả lời
13
Đọc
19K
lymaianh.nhi
L
T
Tìm kiếm nhanh cột lọc Filter
Trả lời
0
Đọc
1
truongvan86dh
T
T
  • Question
Tách sheet tổng hợp dữ nguyên định dạng và có liên kết các sheet con với sheet tổng
Trả lời
0
Đọc
14
ttsuong
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom