'C--2
'G--3
'T--4
'好像只有這四種字母，怎麽感覺像是基因堿基對啊。
Option Explicit
Private Sub Command1_Click()
Dim i As Long, j As Long, k As Long
Dim S As String, SS As String
Dim M() As Integer, N As Long
Dim Fc() As Integer, Fg() As Integer, Fcpg() As Integer, Fgpc() As Integer, P() As Double, R() As Double, FN As Long
Dim DTa As Double, DTb As Double
S = Text1.Text '讀取數據，也可以改成從TXT文件中讀取。
N = Len(S)
ReDim M(1 To N)
For i = 1 To N
SS = Mid(S, i, 1)
Select Case SS
Case "A"
M(i) = 1
Case "C"
M(i) = 2
Case "G"
M(i) = 3
Case "T"
M(i) = 4
Case Else
MsgBox "數據來源中有異常數據，第 " & CStr(i) & " 個數據不是ACGT，退出。", , ""
Exit Sub
End Select
Next i
S = ""
If N < 51 Then
MsgBox "數據來源中的數據少於51個，退出。", , ""
Exit Sub
End If
FN = N - 49
ReDim Fc(1 To FN)
ReDim Fg(1 To FN)
ReDim Fcpg(1 To FN)
ReDim Fgpc(1 To FN)
ReDim P(1 To FN)
ReDim R(1 To FN)
For i = 1 To 50
If M(i) = 2 Then Fc(1) = Fc(1) + 1
If M(i) = 3 Then Fg(1) = Fg(1) + 1
Next i
For i = 1 To 49
If M(i) = 2 And M(i + 1) = 3 Then Fcpg(1) = Fcpg(1) + 1
If M(i) = 3 And M(i + 1) = 2 Then Fgpc(1) = Fgpc(1) + 1
Next i
j = Fc(1) + Fg(1)
If j > 0 Then
P(1) = 4 * Fcpg(1) / (j * j)
Else
P(1) = -1
End If
If Fgpc(1) > 0 Then
R(1) = Fcpg(1) / Fgpc(1)
Else
R(1) = -1
End If
For i = 2 To FN
Fc(i) = Fc(i - 1)
Fg(i) = Fg(i - 1)
Fcpg(i) = Fcpg(i - 1)
Fgpc(i) = Fgpc(i - 1)
If M(i - 1) = 2 Then
Fc(i) = Fc(i) - 1
If M(i) = 3 Then Fcpg(i) = Fcpg(i) - 1
End If
If M(i - 1) = 3 Then
Fg(i) = Fg(i) - 1
If M(i) = 2 Then Fgpc(i) = Fgpc(i) - 1
End If
If M(i + 49) = 2 Then
Fc(i) = Fc(i) + 1
If M(i + 48) = 3 Then Fgpc(i) = Fgpc(i) + 1
End If
If M(i + 49) = 3 Then
Fg(i) = Fg(i) + 1
If M(i + 48) = 2 Then Fcpg(i) = Fcpg(i) + 1
End If
j = Fc(i) + Fg(i)
If j > 0 Then
P(i) = 4 * Fcpg(i) / (j * j)
Else
P(i) = -1
End If
If Fgpc(i) > 0 Then
R(i) = Fcpg(i) / Fgpc(i)
Else
R(i) = -1
End If
Next i
'以下是輸出，也可以改成輸出到TXT文件。其中-1表示除數為0。
S = "P" & Chr(9) & Chr(9) & "R" & vbCrLf
For i = 1 To FN
'S = S & CStr(P(i)) & Chr(9) & CStr(R(i)) & vbCrLf
S = S & Format(P(i), "0.000000") & Chr(9) & CStr(R(i)) & vbCrLf
Next i
Text2.Text = S
End Sub