Option Explicit Dim qx(5) As Double, px(5) As Double Dim qy(5) As Double, py(5) As Double Dim n As Integer Private Sub CommandButton1_Click() Dim w(7) As Double Dim c(16) As Double Dim d(16) As Double Dim dt As Double Dim i As Integer, k As Integer, j As Integer Dim pi As Double Dim ang As Double Application.ScreenUpdating = False w(1) = 0.311790812418427 w(2) = -1.55946803821447 w(3) = -1.6789692825964 w(4) = 1.66335809963315 w(5) = -1.06458714789183 w(6) = 1.36934946416871 w(7) = 0.629030650210433 w(0) = 1# - 2# * (w(1) + w(2) + w(3) + w(4) + w(5) + w(6) + w(7)) d(1) = w(7) d(15) = w(7) d(2) = w(6) d(14) = w(6) d(3) = w(5) d(13) = w(5) d(4) = w(4) d(12) = w(4) d(5) = w(3) d(11) = w(3) d(6) = w(2) d(10) = w(2) d(7) = w(1) d(9) = w(1) d(8) = w(0) d(16) = 0# c(1) = 0.5 * w(7) c(16) = 0.5 * w(7) c(2) = 0.5 * (w(7) + w(6)) c(15) = 0.5 * (w(7) + w(6)) c(3) = 0.5 * (w(6) + w(5)) c(14) = 0.5 * (w(6) + w(5)) c(4) = 0.5 * (w(5) + w(4)) c(13) = 0.5 * (w(5) + w(4)) c(5) = 0.5 * (w(4) + w(3)) c(12) = 0.5 * (w(4) + w(3)) c(6) = 0.5 * (w(3) + w(2)) c(11) = 0.5 * (w(3) + w(2)) c(7) = 0.5 * (w(2) + w(1)) c(10) = 0.5 * (w(2) + w(1)) c(8) = 0.5 * (w(1) + w(0)) c(9) = 0.5 * (w(1) + w(0)) n = 3 qx(1) = 0.97000436 qy(1) = -0.24308753 px(1) = -0.5 * 0.93240737 py(1) = -0.5 * 0.86473146 qx(2) = -0.97000436 qy(2) = 0.24308753 px(2) = -0.5 * 0.93240737 py(2) = -0.5 * 0.86473146 qx(3) = 0# qy(3) = 0# px(3) = 0.93240737 py(3) = 0.86473146 Worksheets("Sheet1").Cells(1, 2) = 0# For j = 1 To n Worksheets("Sheet1").Cells(1, 1 + 2 * j) = qx(j) Worksheets("Sheet1").Cells(1, 2 + 2 * j) = qy(j) Next j dt = 2.1 / 1000 For i = 1 To 1000 Worksheets("Sheet1").Cells(i + 1, 2) = dt * i For k = 1 To 16 For j = 1 To n qx(j) = qx(j) + dt * c(k) * px(j) qy(j) = qy(j) + dt * c(k) * py(j) Next j For j = 1 To n px(j) = px(j) + dt * d(k) * fx(j) py(j) = py(j) + dt * d(k) * fy(j) Next j Next k For j = 1 To n Worksheets("Sheet1").Cells(1 + i, 1 + 2 * j) = qx(j) Worksheets("Sheet1").Cells(1 + i, 2 + 2 * j) = qy(j) Next j Next i Application.ScreenUpdating = True End Sub Function fx(k As Integer) As Double Dim i As Integer Dim f As Double, R As Double Dim G As Double G = 1 f = 0 For i = 1 To n If i <> k Then R = Sqr((qx(i) - qx(k)) ^ 2 + (qy(i) - qy(k)) ^ 2) f = f + G * (qx(i) - qx(k)) / (R ^ 3) End If Next i fx = f End Function Function fy(k As Integer) As Double Dim i As Integer Dim f As Double, R As Double Dim G As Double G = 1 f = 0 For i = 1 To n If i <> k Then R = Sqr((qx(i) - qx(k)) ^ 2 + (qy(i) - qy(k)) ^ 2) f = f + G * (qy(i) - qy(k)) / (R ^ 3) End If Next i fy = f End Function