Sub MolecularPresence()
Dim i As Long, j As Long, lr As Long, c As Long, molCount As Long
Dim msSimilarityThreshold As Double, rtSimilarityThreshold As Double
Dim a As Range, b, sampleObj, molObj
Dim acs As Worksheet, ns As Worksheet, ns2 As Worksheet
Application.ScreenUpdating = False
msSimilarityThreshold = 0.01
rtSimilarityThreshold = 0.1
Set acs = ActiveSheet
Set ns = Sheets.Add
ns.Cells(1, 1).Resize(, 5).Value = Array("Sample", "Mass", "RT", "Vol", "Molecule")
Set ns2 = Sheets.Add
With acs
Set a = .Cells(1, 1)
Do While a.Column <> .Columns.Count
With a.End(xlDown).CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1, 3)
b = .Value
With ns.Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(.Rows.Count)
.Resize(, 3).Value = b
.Offset(, -1).Value = a.Value
End With
End With
End With
Set a = a.End(xlToRight)
Loop
End With
Set sampleObj = CreateObject("scripting.dictionary")
Set molObj = CreateObject("scripting.dictionary")
sampleObj.comparemode = 1
molObj.comparemode = 1
With ns
.Name = "Data Rearranged"
lr = .Cells(Rows.Count, 1).End(xlUp).Row
molCount = 1
For i = 2 To lr
If Not sampleObj.Exists(.Cells(i, 1).Value) Then sampleObj.Add .Cells(i, 1).Value, 1
If .Cells(i, 5).Value = "" Then
.Cells(i, 5).Value = molCount
If Not molObj.Exists(molCount) Then molObj.Add molCount, Format(.Cells(i, 2).Value, "0.0000") & " / " & Format(.Cells(i, 3).Value, "0.000")
For j = i + 1 To lr
If Abs(.Cells(i, 2).Value - .Cells(j, 2).Value) <= msSimilarityThreshold And _
Abs(.Cells(i, 3).Value - .Cells(j, 3).Value) <= rtSimilarityThreshold Then
.Cells(j, 5).Value = molCount
End If
Next
molCount = molCount + 1
End If
Next
End With
With ns2
.Name = "Presence"
.Cells(1, 1).Resize(, 2).Value = Array("Molecule", "Mass / RT")
.Cells(1, 3).Resize(, sampleObj.Count).Value = sampleObj.keys
.Cells(2, 1).Resize(molObj.Count).Value = Application.Transpose(molObj.keys)
.Cells(2, 2).Resize(molObj.Count).Value = Application.Transpose(molObj.items)
For i = 2 To lr
.Cells(.Columns(1).Find(ns.Cells(i, 5).Value).Row, .Rows(1).Find(ns.Cells(i, 1).Value).Column).Value = 1
Next
Intersect(.Columns(3).Resize(, sampleObj.Count), .UsedRange).SpecialCells(xlCellTypeBlanks).Value = 0
.Columns.AutoFit
End With
Set sampleObj = Nothing
Set molObj = Nothing
Set acs = Nothing
Set ns = Nothing
Set ns2 = Nothing
Application.ScreenUpdating = True
End Sub
Bookmarks