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 :)

Tyr turning the calculation off at the start and back on at the end.

Application.calcualtion = xlManual
....
Application.calculation = xlAutomatic

Whenever you toggle these appliation settings it is a good Idea to impliment
an error handler to reset thme in case of a problem.

Hope this works...

"gaba" wrote:

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 :)

Thanks for your answer, Jim. It is giving me an error... I'm retracing what I
added at the end and it is making it so slow.
Soon as I find what's wrong I'll post it
Thanks a lot,
Gaba

"Jim Thomlinson" wrote:

Tyr turning the calculation off at the start and back on at the end.

Application.calcualtion = xlManual
...
Application.calculation = xlAutomatic

Whenever you toggle these appliation settings it is a good Idea to impliment
an error handler to reset thme in case of a problem.

Hope this works...

I don't get it... I've created the macro in a copy spreadsheet. Once it was
working I copied it to the template (a read only version). That's where the
slowing down problems began.. I went back to the copy spreadsheet and it is
working fast as it is supposed to be...
The error was because of a typo in calcualtions... Still not changing the
speed...
Any ideas?

"gaba" wrote:

Thanks for your answer, Jim. It is giving me an error... I'm retracing what I
added at the end and it is making it so slow.
Soon as I find what's wrong I'll post it
Thanks a lot,
Gaba

"Jim Thomlinson" wrote:

Tyr turning the calculation off at the start and back on at the end.

Application.calcualtion = xlManual
...
Application.calculation = xlAutomatic

Whenever you toggle these appliation settings it is a good Idea to impliment
an error handler to reset thme in case of a problem.

Hope this works...