Hi All
This macro is doing what is intended to do, but it is running soooooo slow.
Is there any way to speed it up? There is a lot of room for improvement. I'm
trying my best but I'm new at this, more likely I'm doing something to make
it so slow
Any help/ideas would be more than appreciated

The idea is to find thru the columns of row 15 the colored cells, loop thru
its rows and copy the colored values into a new location, go to next and do
the same to the last column.

Thanks

Sub Select_Results()

Dim te As Long 'total elements
Dim LastEl As Long 'Last Element Row
Dim lastC As String 'Last column letter
Dim LCol As Long 'Last column number
Dim i As Long
Dim e As Long
Dim oRng As Range 'to go back to original range
Dim firstRng As Range 'range to find value
Dim DestCol As Long 'Destination column
Dim DestRow As Long 'Destination row
Dim oCol As Long 'zero column
Dim MethRange As Range, SrcChk1 As Range
Dim SrcFnd1 As String, SrcFnd2 As String, SrcFnd3 As String, SrcFnd4 As
String, SrcFnd5 As String, SrcFnd6 As String, DestChk1 As String

Set MethRange = Sheets("Method Ids").Range("A3:A61")

myfilename = Range("H3").Value

Sheets("Results " & myfilename & " data").Select

te = Range("F6").Value
LastEl = (te + 15)
lastC = Range("I100").Value

DestCol = Columns("E").Column - 8
oCol = Columns("E").Column
DestRow = LastEl + 5
oRow = LastEl + 5
LCol = Range("E15").End(xlToRight).Column

With Worksheets("Results " & myfilename & " data").Range("E15").Select
For e = 1 To LCol

Set oRng = Cells(15, e + 4)

On Error Resume Next
Set firstRng = Cells.Find(What:=ActiveCell.Offset(0, 0).Value, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns)
If Not firstRng Is Nothing Then
If ActiveCell.Offset(0, 0).Interior.ColorIndex = 8 Then
ActiveCell.Offset(1, 0).Select
DestCol = DestCol + 8
DestRow = oRow
For i = 1 To te

If ActiveCell.Interior.ColorIndex = 8 Then

Cells(DestRow, DestCol).Value = Cells(ActiveCell.Row(),
1).Value

DestChk1 = Cells(ActiveCell.Row(), 1).Value
Set SrcChk1 = MethRange.Find(What:=DestChk1,
LookAt:=xlWhole, _
SearchOrder:=xlByColumns)

If Not SrcChk1 Is Nothing Then
SrcFnd1 = SrcChk1.Offset(0, 5).Value 'reporting
unit
SrcFnd2 = SrcChk1.Offset(0, 6).Value / 1000 '
detection limit
SrcFnd3 = SrcChk1.Offset(0, 19).Value 'method used
SrcFnd4 = SrcChk1.Offset(0, 20).Value 'date
End If

SrcFnd5 = Cells(15, ActiveCell.Column()).Value
SrcFnd6 = Cells(11, ActiveCell.Column()).Value

Cells(DestRow, DestCol).Value =
Cells(ActiveCell.Row(), 1).Value

If Cells(DestRow - 1, DestCol + 1).Value = "" Then
Cells(DestRow - 1, DestCol + 1).Value =
SrcFnd5 'SrcFnd5
End If

With Cells(DestRow, DestCol + 1)
.Formula = "=" &
ActiveCell.Address(external:=True)
.NumberFormat = ActiveCell.NumberFormat
.Interior.ColorIndex = 8

End With
Cells(DestRow, DestCol + 2).Value = SrcFnd1
Cells(DestRow, DestCol + 3).Value = SrcFnd6
Cells(DestRow, DestCol + 4).Value = SrcFnd2
Cells(DestRow, DestCol + 5).Value = SrcFnd3
Cells(DestRow, DestCol + 6).Value = SrcFnd4
Cells(DestRow, DestCol + 6).NumberFormat =
"mm/dd/yyyy"
DestRow = DestRow + 1

End If
ActiveCell.Offset(1, 0).Select
Next i
End If

End If
oRng.Select
ActiveCell.Offset(0, 1).Select
Next e
End With
Range("H2").Select
End Sub
--
gaba :)