Option Explicit
Sub Meh_MakeWithTheCrosses_See()
Dim nx As Integer, ny As Integer
Dim FemIndex As Integer, MalIndex As Integer
Dim LocusIndex As Integer, LocusGenotype As Integer
Dim FemList() As Integer, MalList() As Integer
Dim FemName() As String, MalName() As String
Dim Numfemales As Integer, NumMales As Integer
Dim NumLoci As Integer
Sheet3.UsedRange.ClearContents
Sheet3.Cells(1, 2) = "Best case scenario"
Sheet3.Cells(1, 7) = "Worst case scenario"
Sheet3.Cells(2, 1) = "Cross"
Sheet3.Cells(2, 2) = "Homo Genes"
Sheet3.Cells(2, 3) = "Het Genes"
Sheet3.Cells(2, 4) = "Poss Hets"
Sheet3.Cells(2, 5) = ""
Sheet3.Cells(2, 6) = "Comments"
Sheet3.Cells(2, 7) = "Homo Genes"
Sheet3.Cells(2, 8) = "Het Genes"
Sheet3.Cells(2, 9) = "Poss Hets"
For nx = 3 To Cells(1, 2) 'determine male/female list
If UCase(Cells(nx, 2)) = "F" Then
Numfemales = Numfemales + 1
ReDim Preserve FemList(Numfemales)
ReDim Preserve FemName(Numfemales)
FemList(Numfemales) = nx
FemName(Numfemales) = Cells(nx, 1)
Else
If UCase(Cells(nx, 2)) = "M" Then
NumMales = NumMales + 1
ReDim Preserve MalList(NumMales)
ReDim Preserve MalName(NumMales)
MalList(NumMales) = nx
MalName(NumMales) = Cells(nx, 1)
End If
End If
Next nx
'all males/females are listed
Dim femGenes() As Integer, malGenes() As Integer
NumLoci = Sheet2.Cells(1, 2)
ReDim femGenes(Numfemales, NumLoci)
ReDim malGenes(NumMales, NumLoci)
Dim LocCode() As String
ReDim LocCode(NumLoci, 2)
'get locus codes
For nx = 3 To NumLoci + 2
LocCode(nx - 2, 0) = Sheet2.Cells(nx, 2) 'dominant
LocCode(nx - 2, 1) = Sheet2.Cells(nx, 3) 'recessive
LocCode(nx - 2, 2) = Sheet2.Cells(nx, 1) 'Trait Name
Next nx
Dim ts As String
'get genotypes in calculatable forms
For nx = 1 To Numfemales
For ny = 1 To NumLoci
'for each locus, check for that code in this animal's genotype
ts = Cells(FemList(nx), 3)
If InStr(1, ts, LocCode(ny, 0), vbTextCompare) > 0 Then
femGenes(nx, ny) = 2
Else
ts = Cells(FemList(nx), 4)
If InStr(1, ts, LocCode(ny, 0), vbTextCompare) > 0 Then
femGenes(nx, ny) = 1
Else
femGenes(nx, ny) = 0
End If
End If
Next ny
Next nx
For nx = 1 To NumMales
For ny = 1 To NumLoci
'for each locus, check for that code in this animal's genotype
ts = Cells(MalList(nx), 3)
If InStr(1, ts, LocCode(ny, 0), vbTextCompare) > 0 Then
malGenes(nx, ny) = 2
Else
ts = Cells(MalList(nx), 4)
If InStr(1, ts, LocCode(ny, 0), vbTextCompare) > 0 Then
malGenes(nx, ny) = 1
Else
malGenes(nx, ny) = 0
End If
End If
Next ny
Next nx
'all males and females are in memory with genotypes
'do crosses
Dim ColInd As Integer, nz As Integer
For nz = 1 To NumLoci
Debug.Print malGenes(1, nz)
Next nz
ColInd = 3
For ny = 1 To Numfemales
'clear the row
For nz = 1 To 9
Sheet3.Cells(ColInd, nz) = ""
Next nz
For nx = 1 To NumMales
Sheet3.Cells(ColInd, 1) = FemName(ny) & " X " & MalName(nx)
'for each gene, see what matches
'results are: Homo, Het, 66%, 50%, non
For nz = 1 To NumLoci
If femGenes(ny, nz) = 0 Then
If malGenes(nx, nz) = 0 Then
'do nothing
ElseIf malGenes(nx, nz) = 1 Then
' 50% poss het, add to "Best" and "worst"
Sheet3.Cells(ColInd, 4) = Sheet3.Cells(ColInd, 4) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 9) = Sheet3.Cells(ColInd, 9) & LocCode(nz, 2) & ", "
Else 'malgenes = 2
' positive het
Sheet3.Cells(ColInd, 3) = Sheet3.Cells(ColInd, 3) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 8) = Sheet3.Cells(ColInd, 8) & LocCode(nz, 2) & ", "
End If
ElseIf femGenes(ny, nz) = 1 Then
If malGenes(nx, nz) = 0 Then
' 50% poss het
Sheet3.Cells(ColInd, 4) = Sheet3.Cells(ColInd, 4) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 9) = Sheet3.Cells(ColInd, 9) & LocCode(nz, 2) & ", "
ElseIf malGenes(nx, nz) = 1 Then
'poss morph, 66% het
Sheet3.Cells(ColInd, 2) = Sheet3.Cells(ColInd, 2) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 9) = Sheet3.Cells(ColInd, 9) & LocCode(nz, 2) & ", "
Else 'malgenes = 2
'poss morph, positive het
Sheet3.Cells(ColInd, 2) = Sheet3.Cells(ColInd, 2) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 8) = Sheet3.Cells(ColInd, 8) & LocCode(nz, 2) & ", "
End If
Else 'femgenes = 2
If malGenes(nx, nz) = 0 Then
' positive het
Sheet3.Cells(ColInd, 3) = Sheet3.Cells(ColInd, 3) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 8) = Sheet3.Cells(ColInd, 8) & LocCode(nz, 2) & ", "
ElseIf malGenes(nx, nz) = 1 Then
'poss morph, positive het
Sheet3.Cells(ColInd, 2) = Sheet3.Cells(ColInd, 2) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 8) = Sheet3.Cells(ColInd, 8) & LocCode(nz, 2) & ", "
Else 'malgenes = 2
'overlap: all morphs
Sheet3.Cells(ColInd, 2) = Sheet3.Cells(ColInd, 2) & LocCode(nz, 2) & ", "
Sheet3.Cells(ColInd, 7) = Sheet3.Cells(ColInd, 7) & LocCode(nz, 2) & ", "
End If
End If
Next nz
ColInd = ColInd + 1
Next nx
For nz = 1 To 9
Sheet3.Cells(ColInd, nz) = ""
Next nz
ColInd = ColInd + 1
Next ny
With Sheet3
For ny = 3 To ColInd
For nx = 2 To 4
ts = .Cells(ny, nx)
If Len(ts) > 0 Then
If Right$(ts, 2) = ", " Then
ts = Left$(ts, Len(ts) - 2)
.Cells(ny, nx) = ts
End If
End If
Next nx
For nx = 7 To 9
ts = .Cells(ny, nx)
If Len(ts) > 0 Then
If Right$(ts, 2) = ", " Then
ts = Left$(ts, Len(ts) - 2)
.Cells(ny, nx) = ts
End If
End If
Next nx
Next ny
End With
'set auto column widths:
'Sheet3.Range("A1", "I1").AutoFit
Sheet3.Activate
'all done
MsgBox "Done, switching to 'results' Sheet."
End Sub