Attribute VB_Name = "DNA_Macros" ' This file consists of several VBA macros ' ' GENETIC DISTANCE ' FindGeneticDistance -- generates new worksheet titled "Genetic Distance" ' Header rows MUST identify markers ' Selected region MUST start from column 1 ' Shows table of distance between every pair of haplotypes ' for selected region ' ' HTML Table creation: ' MakeHtmlTable -- creates small HTML table of the selected area ' of the worksheet and copies it to the clipboard ' WriteHtmlTable -- Same as above but also writes to file "C:\htmltable.html" ' ' COLOR identification of haplotype differences ' The following three macros all will change the background color of the selected ' region depending on differences between each cell's value and a reference cell ' for that column. Three methods of choosing the reference cell are provided; ' one method for each macro ' SetBGColorModalReference -- the reference is the modal value for each selected column ' SetBGColorMedianReference -- the reference is the median value for each selected column ' SetBGColorFirstRowReference -- the reference is the first row in the selected region ' SetBGColorAnyRowReference -- the reference is the row given in a prompt box asking for ' -- the reference row number ' ResetBGColor -- Resets background color of selected area to white ' ' These macros were written by Dean McGee, dean.mcgee@mymcgee.com ' You are welcome to use and/or modify them for any purpose as you see fit ' I appreciate any comments, suggestions, or improvements you might have ' ' Modification history ' 20040131 - hdm - initial code ' 20040314 - hdm - support genetic distances, modal reference, misc exception handling ' Const ID_HEADER1 = "name" ' Header of column used for identification in ' Genetic Difference table Const ID_HEADER2 = "kit" ' Header of column used for identification if ' ID_HEADER1 isn't found Const DIFF0 = &H10FFFFFF ' white : background color for no differences Const DIFF1 = &H10C0FFC0 ' pale green : background color for difference of 1 Const DIFF2 = &H1080FFFF ' pale yellow : background color for difference of 2 Const DIFF3 = &H108080FF ' pale red : background color for difference of 3 or more Const DIFF_ERR = &H10FF8080 ' pale blue : background color for exceptions Const OutputFileName = "C:\DNA_Table.html" ' Output file name for WriteHtmlTable Const FirstRow = -1 Const MedianRow = -2 Const ModalRef = -3 Const MAXMARKER = 100 Public RowNum As Integer Private iMaxCol As Integer Private idxDYS389(2) As Integer Private idxDYS464(7) As Integer Private DYS464_HitA(30) As Integer Private DYS464_HitB(30) As Integer Private strMarker(MAXMARKER) As String * 12 Private iMarkerCount(MAXMARKER) As Integer Private IDcol As Integer Public Sub MakeHtmlTable() Dim CurrentRow As Long Dim TableStart As Boolean Dim st As String Dim strTable As String Dim dobj As New DataObject CurrentRow = 0 TableStart = True strTable = "" & vbCrLf strTable = strTable & " " For Each Row In Selection.Rows strTable = strTable & "" & vbCrLf For Each cell In Row.Cells st = Hex(cell.Interior.Color) While Len(st) < 6 st = "0" & st Wend If st = "FFFFFF" Then If "" <> cell.Value Then strTable = strTable & "" & vbCrLf Else strTable = strTable & "" & vbCrLf End If Else strTable = strTable & "" & vbCrLf End If Next cell strTable = strTable & "" & vbCrLf Next Row strTable = strTable & "

" & cell.Value & "

" & vbCrLf strTable = strTable & "" & vbCrLf dobj.SetText strTable dobj.PutInClipboard End Sub ' MakeHtmlTable Public Sub WriteHtmlTable() Dim f As Integer Dim strTable As String Dim dobj As New DataObject ans = MsgBox("This will create/overwrite the file """ & OutputFileName & """" & vbCrLf & _ vbCrLf & "Is this OK?", vbOKCancel, "OK to write file?") If ans = vbOK Then f = FreeFile MakeHtmlTable dobj.GetFromClipboard strTable = dobj.GetText Open OutputFileName For Output As f Print #f, strTable Close f End If End Sub ' WriteHtmlTable Public Sub ResetBGColor() For Each col In Selection.Columns For Each cell In col.Cells cell.Interior.Color = vbWhite Next cell Next col End Sub ' ResetBGColor Public Sub SetBGColorMedianReference() SetColors MedianRow End Sub ' SetBGColorMedianReference Public Sub SetBGColorModalReference() SetColors ModalRef End Sub ' SetBGColorMedianReference Public Sub SetBGColorFirstRowReference() SetColors FirstRow End Sub ' SetBGColorFirstRowReference Public Sub SetBGColorAnyRowReference() frmDNA_Row.Show vbModal If (RowNum > 0) And (RowNum < 500) Then SetColors RowNum End If End Sub ' SetBGColorAnyRowReference Private Sub SetColors(iRowNum As Integer) Dim reference As Long Dim diff As Long Dim a Dim wks As Worksheet Dim mycol As Range blankcol = False For Each col In Selection.Columns On Error GoTo DoNext If iRowNum = MedianRow Then reference = MyMedian(col) ElseIf iRowNum = ModalRef Then 'reference = Application.WorksheetFunction.Mode(col) reference = MyMode(col) ElseIf iRowNum = FirstRow Then If Application.WorksheetFunction.IsNumber(col.Cells(1, 1).Value) = False Then GoTo DoNext End If reference = Round(col.Cells(1, 1).Value + 0.01) Else strng = col.Address a = Split(strng, "$") Set wks = Selection.Parent If IsNumeric(wks.Cells(iRowNum, a(1)).Value) Then reference = wks.Cells(iRowNum, a(1)).Value If reference <= 0 Then GoTo DoNext End If Else GoTo DoNext End If End If For Each cell In col.Cells If IsNumeric(cell.Value) And (cell.Value > 0) Then diff = Abs(Round(cell.Value - reference + 0.01)) Select Case diff Case 0 cell.Interior.Color = DIFF0 Case 1 cell.Interior.Color = DIFF1 Case 2 cell.Interior.Color = DIFF2 Case Else cell.Interior.Color = DIFF3 End Select Else If IsValid(cell.Value) Then cell.Interior.Color = DIFF_ERR End If End If Next cell GoTo NextCol DoNext:: For Each cell In col.Cells cell.Interior.Color = DIFF_ERR Next cell NextCol:: Next col End Sub ' SetBGColor Private Function MyMedian(ByVal col As Range) As Integer Dim iValues(100) As Integer Dim i As Integer Dim idx As Integer Dim iCount As Integer Dim iMedian As Integer For i = 0 To 100 iValues(i) = 0 Next i iCount = 0 For Each cell In col.Cells If IsValid(cell.Value) Then idx = Round(cell.Value + 0.01) iValues(idx) = iValues(idx) + 1 iCount = iCount + 1 End If Next cell iCount = iCount \ 2 + 1 iMedian = 0 idx = 0 While iMedian < iCount idx = idx + 1 iMedian = iMedian + iValues(idx) Wend MyMedian = idx End Function ' MyMedian Private Function MyMode(ByVal col As Range) As Integer Dim iValues(100) As Integer Dim i As Integer Dim idx As Integer Dim iMaxCount As Integer Dim iMaxIdx As Integer For i = 0 To 100 iValues(i) = 0 Next i iMaxCount = 0 iMaxIdx = 0 For Each cell In col.Cells If IsValid(cell.Value) Then idx = Round(cell.Value + 0.01) If idx < 99 Then iValues(idx) = iValues(idx) + 1 If iValues(idx) > iMaxCount Then iMaxCount = iValues(idx) iMaxIdx = idx End If End If End If Next cell MyMode = iMaxIdx End Function ' MyMode Private Function IsValid(data) As Boolean If IsNumeric(data) And _ (Len(Trim(CStr(data))) > 0) Then IsValid = True Else IsValid = False End If End Function ' IsValid Private Sub SetWorksheet(name As String, wks As Worksheet) For Each Sheet In Application.Sheets If Sheet.name = name Then found = True Set wks = Sheet End If Next Sheet If Not found Then Set wks = Application.Sheets.Add wks.name = name End If End Sub ' SetWorksheet Private Sub ShowStats(wks As Worksheet) Dim iRow As Integer wks.Cells(1, 1) = "Marker" wks.Cells(1, 2) = "Count" iRow = 1 For i = 1 To MAXMARKER If Len(Trim(strMarker(i))) > 0 Then iRow = iRow + 1 wks.Cells(iRow, 1) = ": " & CStr(strMarker(i)) wks.Cells(iRow, 2) = iMarkerCount(i) End If Next i wks.Cells(1, 4) = "Special" wks.Cells(1, 5) = "Count" wks.Cells(2, 4) = "DYS389i" wks.Cells(3, 4) = "DYS389ii" wks.Cells(2, 5) = iMarkerCount(idxDYS389(1)) wks.Cells(3, 5) = iMarkerCount(idxDYS389(2)) wks.Cells(1, 7) = "Special" wks.Cells(1, 8) = "Count" wks.Cells(2, 7) = "DYS464a" wks.Cells(3, 7) = "DYS464b" wks.Cells(4, 7) = "DYS464c" wks.Cells(5, 7) = "DYS464d" wks.Cells(6, 7) = "DYS464e" wks.Cells(7, 7) = "DYS464f" wks.Cells(8, 7) = "DYS464g" wks.Cells(2, 8) = iMarkerCount(idxDYS464(1)) wks.Cells(3, 8) = iMarkerCount(idxDYS464(2)) wks.Cells(4, 8) = iMarkerCount(idxDYS464(3)) wks.Cells(5, 8) = iMarkerCount(idxDYS464(4)) wks.Cells(6, 8) = iMarkerCount(idxDYS464(5)) wks.Cells(7, 8) = iMarkerCount(idxDYS464(6)) wks.Cells(8, 8) = iMarkerCount(idxDYS464(7)) End Sub ' ShowStats Private Sub GetDataStart(wks As Worksheet, iDataRow As Integer, iDataCol As Integer) Dim done As Boolean Dim tmpstr As String If iDataCol > 1 Then done = False While Not done iDataRow = iDataRow + 1 tmpstr = wks.Cells(iDataRow, iDataCol) If IsValid(wks.Cells(iDataRow, iDataCol)) Then If wks.Cells(iDataRow, iDataCol) < 100 Then done = True End If End If If iDataRow > 12 Then done = True End If Wend done = False If iDataRow < 12 Then While Not done iDataCol = iDataCol - 1 tmpstr = wks.Cells(iDataRow, iDataCol) If IsValid(wks.Cells(iDataRow, iDataCol)) Then If wks.Cells(iDataRow, iDataCol) > 100 Then done = True iDataCol = iDataCol + 1 End If Else done = True iDataCol = iDataCol + 1 End If If iDataCol < 2 Then done = True End If Wend End If End If End Sub ' GetDataStart Private Sub GetMarkers(wks As Worksheet, iDataRow As Integer, iDataCol As Integer) ' algorithm: search columns by concatenated rows for "390" ' first row after 390 with numeric entry is iDataRow ' starting in iDataRow and 390 column, search left for last numeric value ' less than 100. That column is iDataCol Dim done As Boolean Dim iRow As Integer Dim iCol As Integer Dim i390Found As Boolean Dim strTemp As String i390Found = False done = False For i = 1 To MAXMARKER strMarker(i) = "" iMarkerCount(i) = 0 Next i iRow = 1 iCol = i iDataRow = 12 While Not done For iCol = 1 To MAXMARKER strTemp = Trim(wks.Cells(iRow, iCol)) strMarker(iCol) = Trim(strMarker(iCol)) & strTemp If (i390Found = False) And (InStr(1, strMarker(iCol), "390") > 0) Then 'done = True i390Found = True iDataCol = iCol iDataRow = iRow GetDataStart wks, iDataRow, iDataCol End If Next iCol iRow = iRow + 1 If iRow >= iDataRow Then done = True End If Wend For i = 2 To MAXMARKER If Len(strMarker(i)) > 0 Then iMaxCol = i End If strTemp = UCase(strMarker(i)) If InStr(1, strMarker(i), "389") > 0 Then If (InStr(1, strTemp, "2") > 0) Or (InStr(1, strTemp, "II") > 0) Then idxDYS389(2) = i Else idxDYS389(1) = i End If End If If InStr(1, strTemp, "464") > 0 Then If InStr(1, strTemp, "A") > 0 Then idxDYS464(1) = i ElseIf InStr(1, strTemp, "B") > 0 Then idxDYS464(2) = i ElseIf InStr(1, strTemp, "C") > 0 Then idxDYS464(3) = i ElseIf InStr(1, strTemp, "D") > 0 Then idxDYS464(4) = i ElseIf InStr(1, strTemp, "E") > 0 Then idxDYS464(5) = i ElseIf InStr(1, strTemp, "F") > 0 Then idxDYS464(6) = i ElseIf InStr(1, strTemp, "G") > 0 Then idxDYS464(7) = i End If End If Next i IDcol = 0 For i = 1 To iDataCol - 1 If InStr(1, LCase(strMarker(i)), LCase(ID_HEADER1)) Then IDcol = i End If Next i If IDcol = 0 Then For i = 1 To idatastart - 1 If InStr(1, LCase(strMarker(i)), LCase(ID_HEADER2)) Then IDcol = i End If Next i End If If IDcol = 0 Then IDcol = 1 End If End Sub ' GetMarkers Public Sub FindGeneticDistances() Attribute FindGeneticDistances.VB_ProcData.VB_Invoke_Func = "k\n14" Dim wks As Worksheet Dim StatSheet As Worksheet Dim i As Integer Dim iRowA As Integer Dim iRowB As Integer Dim RowA As Range Dim RowB As Range Dim strA As String Dim strB As String Dim iDataRow As Integer Dim iDataCol As Integer Dim GeneticDistance As Integer found = False SetWorksheet "Genetic Distance", wks wks.Rows.Clear SetWorksheet "Statistics", StatSheet StatSheet.Rows.Clear GetMarkers Selection.Parent, iDataRow, iDataCol RowNum = 1 colnum = 1 iRowA = 0 For Each RowA In Selection.Rows iRowA = iRowA + 1 iRowB = 0 For Each RowB In Selection.Rows iRowB = iRowB + 1 GeneticDistance = 0 For i = 1 To 30 DYS464_HitA(i) = 0 DYS464_HitB(i) = 0 Next i For iCol = iDataCol To iMaxCol strA = RowA.Cells(1, iCol).Value strB = RowB.Cells(1, iCol).Value If (iCol = idxDYS389(2)) Then ' DYS389b is handled separately below ElseIf (iCol = idxDYS464(1)) Or (iCol = idxDYS464(2)) Or _ (iCol = idxDYS464(3)) Or (iCol = idxDYS464(4)) Or _ (iCol = idxDYS464(5)) Or (iCol = idxDYS464(6)) Or _ (iCol = idxDYS464(7)) Then ' Special handling for DYS464 If IsValid(RowA.Cells(1, iCol).Value) And IsValid(RowB.Cells(1, iCol).Value) Then ival = Round(RowA.Cells(1, iCol).Value + 0.01) DYS464_HitA(ival) = DYS464_HitA(ival) + 1 ival = Round(RowB.Cells(1, iCol).Value + 0.01) DYS464_HitB(ival) = DYS464_HitB(ival) + 1 End If ElseIf (iCol = idxDYS464(2)) Then ElseIf (iCol = idxDYS464(3)) Then ElseIf (iCol = idxDYS464(4)) Then ElseIf (iCol = idxDYS464(5)) Then ElseIf (iCol = idxDYS464(6)) Then ElseIf (iCol = idxDYS464(7)) Then ElseIf IsValid(RowA.Cells(1, iCol).Value) And _ IsValid(RowB.Cells(1, iCol).Value) Then ' treat all other markers (known or unknown) as normal GeneticDistance = GeneticDistance + _ Abs(RowA.Cells(1, iCol).Value - RowB.Cells(1, iCol).Value) End If If iRowA = iRowB Then If IsValid(RowA.Cells(1, iCol)) Then iMarkerCount(iCol) = iMarkerCount(iCol) + 1 End If End If Next iCol If (idxDYS389(1) > 0) And (idxDYS389(2) > 0) Then If IsValid(RowA.Cells(1, idxDYS389(1)).Value) And _ IsValid(RowA.Cells(1, idxDYS389(2)).Value) And _ IsValid(RowB.Cells(1, idxDYS389(1)).Value) And _ IsValid(RowB.Cells(1, idxDYS389(2)).Value) Then GeneticDistance = GeneticDistance + _ Abs(RowA.Cells(1, idxDYS389(2)).Value - RowA.Cells(1, idxDYS389(1)).Value - _ (RowB.Cells(1, idxDYS389(2)).Value - RowB.Cells(1, idxDYS389(1)).Value)) End If End If For i = 1 To 30 If DYS464_HitA(i) > DYS464_HitB(i) Then GeneticDistance = GeneticDistance + Abs(DYS464_HitA(i) - DYS464_HitB(i)) End If Next i wks.Cells(iRowA + 1, iRowB + 1).Value = GeneticDistance If iRowA = iRowB Then wks.Cells(iRowA + 1, iRowB + 1).Value = "-" End If If (GeneticDistance = 0) And (iRowA <> iRowB) Then wks.Cells(iRowA + 1, iRowB + 1).Interior.Color = DIFF1 End If If (GeneticDistance = 1) And (iRowA <> iRowB) Then wks.Cells(iRowA + 1, iRowB + 1).Interior.Color = DIFF2 End If Next RowB wks.Cells(1, iRowA + 1).Value = RowA.Cells(1, IDcol).Value wks.Cells(iRowA + 1, 1).Value = RowA.Cells(1, IDcol).Value Next RowA ShowStats StatSheet wks.Activate End Sub ' FindGeneticDistances