[Nhờ sửa] giúp em sửa đoan code VBA về hàm nội suy 1,2 chiều

[quansla 259]

Em đang tự học VBA, hiện nay đang chập choẹ viết code

Yêu cầu đặt ra là viết ra hàm mới (noisuy1 và noisuy2) tương ứng là nội suy tuyến tính 1 và 2 chiều cho Excel với VBA

Tên hàm : noisuy1,noisuy2

Tham số hàm

1. Hàm noisuy1 là (bang,giá trị nội suy, cột cần nội suy)
2. Hàm noisuy2 là (bang,giá trị nội suy tra trong cột đầu tiên của bảng, giá trị nội suy tra trong hàng đầu tiên của bang)

Hay viết gọn là noisuy1(bang,X,n) và noisuy2(bang,X,Y)

em có gửi kèm file minh họa excel và fiel txt chứa code VBA (do mới học VBA em vẫn chưa biết làm sao Add code VBA kèm vào file và Add code VBA thành Add in cho Excel, ai biết xin chỉ dùm em luôn, em dùng Office 2010)

http://www.cadviet.com/upfiles/3/101306_noi_suy.rar

Code thì nếu pro nào ngại download thì nó như thế này ạ

Function noisuy2(bang As Range, X As Double, Y As Double) As Variant
    Dim i, n As Integer
    Dim x1, x2, y11, y12, y21, y22 As Double
    Dim min, max As Double
    min = bang.Cells(2, 1)
    max = min
    x1 = 0: x2 = 0: y1 = 0: y2 = 0
    For i = 1 To bang.Rows.Count
        If bang.Cells(i, 1) <= min Then
        min = bang.Cells(i, 1)
        End If
        If bang.Cells(i, 1) >= max Then
        max = bang.Cells(i, 1)
        End If
    Next i
    If (X < min Or X > max) Then
        'MsgBox "gia tri can noi suy vuot tham chieu bang", vbInformation
        noisuy2 = CVErr(xlErrNA)
        Exit Function
        End If
    
    
    min = bang.Cells(1, 2)
    max = min
    For i = 1 To bang.Columns.Count
        If bang.Cells(1, i) <= min Then
        min = bang.Cells(1, i)
        End If
        If bang.Cells(1, i) >= max Then
        max = bang.Cells(1, i)
        End If
    Next i
    If (Y < min Or Y > max) Then
        'MsgBox "gia tri can noi suy vuot tham chieu bang", vbInformation
        noisuy2 = CVErr(xlErrNA)
        Exit Function
        End If
    
    
    'Tim vi tri cot nam giua cot n va n+1 can noi suy
    For i = 2 To bang.Columns.Count
        If bang.Cells(1, i) <= Y And bang.Cells(1, i + 1) >= Y Then
        n = i
        End If
        If bang.Cells(1, i) >= Y And bang.Cells(1, i + 1) <= Y Then
        n = i
        End If
    Next i
      
    'Ket thuc viec tim n gio tim vi tri cua m cua x
    
    For i = 1 To bang.Rows.Count
        If bang.Cells(i, 1) <= X And bang.Cells(i + 1, 1) >= X Then
            m = i
        End If
        If bang.Cells(i, 1) >= X And bang.Cells(i + 1, 1) <= X Then
            m = i
        End If
    Next i
    'Ket thuc viec tim m den day da co du m, n de xac dinh cac
    '      1   a(n)    b(n+1)
    'm    x1   y11     y12
    'm+1  x2   y21     y22
    a = bang.Cells(1, n)
    b = bang.Cells(1, n + 1)
    x1 = bang.Cells(m, 1)
    x2 = bang.Cells(m + 1, 1)
    y11 = bang.Cells(m, n)
    y22 = bang.Cells(m + 1, n + 1)
    Dim yy1, yy2 As Double
    If ((b - a <> 0) And (x2 - x1 <> 0)) Then
        yy1 = y11 + (y21 - y11) / (x2 - x1) * (X - x1)
        yy2 = y12 + (y22 - y12) / (x2 - x1) * (X - x1)
        noisuy2 = yy1 + (yy2 - yy1) / (b - a) * (Y - a)
        Else
            If (y1 = y2) Then
            noisuy2 = y2
            Else
            noisuy2 = CVErr(xlErrDiv0)
            Exit Function
            End If
        End If
End Function







Function noisuy1(bang As Range, X As Double, n As Integer) As Variant
    Dim i As Integer
    Dim x1, x2, y1, y2 As Double
    Dim min, max As Double
    min = bang.Cells(1, 1)
    max = min
    For i = 1 To bang.Rows.Count
        If bang.Cells(i, 1) <= min Then
        min = bang.Cells(i, 1)
        End If
        If bang.Cells(i, 1) >= max Then
        max = bang.Cells(i, 1)
        End If
    Next i
    If (X < min Or X > max) Then
        'MsgBox "gia tri can noi suy vuot tham chieu bang", vbInformation
        noisuy1 = CVErr(xlErrNA)
        Exit Function
        End If
    If (n > bang.Columns.Count) Then
        'MsgBox "cot noi suy vuot so cot trong tham chieu bang", vbInformation
        noisuy1 = CVErr(xlErrNA)
        Exit Function
        End If
    x1 = 0: x2 = 0: y1 = 0: y2 = 0
    For i = 1 To bang.Rows.Count
        If bang.Cells(i, 1) <= X And bang.Cells(i + 1, 1) >= X Then
            x1 = bang.Cells(i, 1)
            x2 = bang.Cells(i + 1, 1)
            y1 = bang.Cells(i, n)
            y2 = bang.Cells(i + 1, n)
        End If
        If bang.Cells(i, 1) >= X And bang.Cells(i + 1, 1) <= X Then
            x1 = bang.Cells(i, 1)
            x2 = bang.Cells(i + 1, 1)
            y1 = bang.Cells(i, n)
            y2 = bang.Cells(i + 1, n)
        End If
    Next i
    
    If (x2 - x1 <> 0) Then
        noisuy1 = y1 + (y2 - y1) / (x2 - x1) * (X - x1)
        Else
            If (y1 = y2) Then
            noisuy1 = y2
            Else
            noisuy1 = CVErr(xlErrDiv0)
            Exit Function
            End If
        End If
End Function

 

quên mất chưa ghi yêu cầu: em nhờ mọi người sửa giúp em cho nó đúng với mọi trường hợp + gọn gàng hơn nhé, em vẫn chưa lường trước được có lỗi gì khi sử dụng cả

 

[quansla 259]

quên mất chưa ghi yêu cầu: em nhờ mọi người sửa giúp em cho nó đúng với mọi trường hợp + gọn gàng hơn nhé, em vẫn chưa lường trước được có lỗi gì khi sử dụng cả

 

 

 

---------------

A, xin lỗi mọi người nhé phần add in vào ẽxcel e vừa làm được rồi

Và cũng xin chú ý là khi sử dụng hàm noisuy2(bang,X,Y) thì bảng bắt buộc phải có kích thước lớn hơn 2x2 và bắt buộc cột đầu tiên và hàng đầu tiên phải chứa giữ liệu để tra X,Y tương ứng nhé

Ví dụ như trong cơ học đất + nền móng thì cột đầu tiên tra X bắt buộc phải là z/b và hàng đầu tiên tra Y sẽ là l/b

[NguyenNgocSon 43]

Bạn sang GPE nhé ! Bên đó vấn đề này đã được xử lý triệt để rồi nhé !

[chuvinh.designer.hd@gmail. 0]

Thi tới hỏi thày đi cho lẹ. nói với thày là em làm ko được nhờ thày làm dùm hic.

[prophetqn 0]

Hàm nội suy mình viết, 1 chiều, 2 chiều đều xài được, nếu giá trị nhập nhỏ hơn giá trị nhỏ nhất tự động lấy giá trị nhỏ nhất, lớn hơn giá trị lớn nhất thì tự lấy giá trị lớn nhất.

'Interpolation function v1.0 by TrungHieu
'Function description: =ns(row_value,column_value,array)

Function ns(x As Variant, y As Variant, z As Variant)
Dim i As Integer, j As Integer, bang(1 To 4, 1 To 4) As Variant, x2 As Integer, x4 As Integer, y2 As Integer, y4 As Integer

bang(1, 3) = x
bang(3, 1) = y

Select Case x
Case Is <= z(1, 2)
    bang(1, 2) = z(1, 2)
    bang(1, 4) = z(1, 2)
    x2 = 2
    x4 = 2
Case Is >= z(1, z.Columns.Count)
    bang(1, 2) = z(1, z.Columns.Count)
    bang(1, 4) = z(1, z.Columns.Count)
    x2 = z.Columns.Count
    x4 = z.Columns.Count
Case Else
    i = 2
    Do While x > z(1, i)
        i = i + 1
    Loop
    bang(1, 2) = z(1, i - 1)
    bang(1, 4) = z(1, i)
    x2 = i - 1
    x4 = i
End Select

Select Case y
Case Is <= z(2, 1)
    bang(2, 1) = z(2, 1)
    bang(4, 1) = z(2, 1)
    y2 = 2
    y4 = 2
Case Is >= z(z.Rows.Count, 1)
    bang(2, 1) = z(z.Rows.Count, 1)
    bang(4, 1) = z(z.Rows.Count, 1)
    y2 = z.Rows.Count
    y4 = z.Rows.Count
Case Else
    j = 2
    Do While y > z(j, 1)
        j = j + 1
    Loop
    bang(2, 1) = z(j - 1, 1)
    bang(4, 1) = z(j, 1)
    y2 = j - 1
    y4 = j
End Select

bang(2, 2) = z(y2, x2)
bang(2, 4) = z(y2, x4)
bang(4, 2) = z(y4, x2)
bang(4, 4) = z(y4, x4)

If bang(2, 2) = bang(2, 4) Then
    bang(2, 3) = bang(2, 2)
Else
    bang(2, 3) = (bang(2, 4) - bang(2, 2)) / (bang(1, 4) - bang(1, 2)) * (bang(1, 3) - bang(1, 2)) + bang(2, 2)
End If

If bang(4, 2) = bang(4, 4) Then
    bang(4, 3) = bang(4, 2)
Else
    bang(4, 3) = (bang(4, 4) - bang(4, 2)) / (bang(1, 4) - bang(1, 2)) * (bang(1, 3) - bang(1, 2)) + bang(4, 2)
End If

If bang(2, 3) = bang(4, 3) Then
    bang(3, 3) = bang(2, 3)
Else
    bang(3, 3) = (bang(4, 3) - bang(2, 3)) / (bang(4, 1) - bang(2, 1)) * (bang(3, 1) - bang(2, 1)) + bang(2, 3)
End If

ns = bang(3, 3)
End Function