Minimise use of SELECT in macro copying data from one sheet to another

[mrjason2008]

Hallo,

I am relatively new to VBA and created a macro, which copies data matching a search term out the 'Database' worksheet into a separate worksheet 'SearchOutput'.

The worksheet 'Database' contains the search term in cell AY2 and the database itself in cell range BM7:PO500. My macro loops through the database and copies every cell, which contains the search term (measured by COUNTIF), into the first free row in worksheet 'SearchOutput'. It also copies two other cells immediately to the right of the cell, which contained the search term.

It took me a few hours to come up with a macro that works :-) However, I noticed that the macro is quite slow, probably because it contains a number of SELECT statements. I searched through the forum and noticed that many people advise to avoid using SELECT and instead to define variables. However, in my specific case, I struggled with understanding how I can achieve the same outcome without using SELECT.

Could you help me? My current code is the following:


Sub CopyDataToSearchOutput()
Dim Datfield As Range
Dim WordPos As Integer

Sheets("Database").Select
Application.ScreenUpdating = False

For Each Datfield In Sheets("Database").Range("BM7:PO500")

'jump over all the calcs if the cell is empty
If Datfield.Text = "" Then GoTo CellEmpty:

'check that the respective cell contains the search term in cell AY2
WordPos = Application.WorksheetFunction.CountIf(Datfield, Range("AY2"))

If WordPos <> 0 Then 'do this if the cell contains the search term

'copy the cell which contains the search term
Datfield.Copy
Sheets("SearchOutput").Select
Range("C1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'copy the corresponding name
Worksheets("Database").Cells(Datfield.Row, Datfield.Column + 1).Copy
Sheets("SearchOutput").Select
Range("D1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'copy the corresponding unit field
Worksheets("Database").Cells(Datfield.Row, Datfield.Column + 2).Copy
Sheets("SearchOutput").Select
Range("E1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Database").Select
End If

CellEmpty: 'jump here if cell is empty

Next Datfield

Application.ScreenUpdating = True
Sheets("SearchOutput").Select
Range("B1").Select
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With

End Sub


Thank you very much in advance for your help. I really appreciate it!

[sm789]

The following should do what you want...


Sub CopyDataToSearchOutput()
Dim Datfield As Range
Dim WordPos As Integer
Sheets("Database").Select
Application.ScreenUpdating = False
For Each Datfield In Sheets("Database").Range("BM7:PO500")
'jump over all the calcs if the cell is empty
If Datfield.Text = "" Then Goto CellEmpty:
'check that the respective cell contains the search term in cell AY2
WordPos = Application.WorksheetFunction.CountIf(Datfield, Range("AY2"))
If WordPos <> 0 Then 'do this if the cell contains the search term
'copy the cell which contains the search term
Range(Selection, Datfield.Offset(0, 2)).Copy
Sheets("SearchOutput").Select
Range("C1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Database").Select
End If
CellEmpty: 'jump here if cell is empty
Next Datfield
Application.ScreenUpdating = True
Sheets("SearchOutput").Select
Range("B1").Select
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
End Sub

[snb]

I fear using advanced filter will produce the same result without any VBA and much, much faster.

[Paul_Hossler]

Not really tested


Option Explicit
Sub CopyDataToSearchOutput()
Dim Datfield As Range, rTemp As Range
Dim WordPos As Integer
Dim sFirstAddress As String


Application.ScreenUpdating = False

With Sheets("Database").Range("BM7:PO500")
Set rTemp = .Find(What:=.Range("AY2").Value, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

If rTemp Is Nothing Then Exit Sub

sFirstAddress = rTemp.Address

Do
Sheets("SearchOutput").Range("C1").End(xlDown).Offset(1, 0).Value = rTemp.Value
Sheets("SearchOutput").Range("D1").End(xlDown).Offset(1, 0).Value = rTemp.Offset(0, 1).Value
Sheets("SearchOutput").Range("E1").End(xlDown).Offset(1, 0).Value = rTemp.Offset(0, 2).Value

Set rTemp = .FindNext(rTemp)

Loop While Not rTemp Is Nothing And rTemp.Address <> sFirstAddress

End With


Application.ScreenUpdating = True
Sheets("SearchOutput").Select
Range("B1").Select
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With

End Sub


Paul

[mrjason2008]

Thank you very much for your replies.

[mrjason2008]

On a second note I found out that data can be copied from a source to the destination without using select. That is, you have one line of conde ending with .copy and then a second line ending with the .PasteSpecial command. I was able to simply the macro as follows:


Sub DataCopy()
Dim Datfield As Range
Dim WordPos As Integer

Sheets("Database").Select
Application.ScreenUpdating = False
For Each Datfield In Sheets("Database").Range("BM7:PO450")

If Datfield.Text = "No data" Then GoTo CellEmpty: 'jump over all the calcs if the cell is empty

'check that the respective cell contains the search term in cell AY2
WordPos = Application.WorksheetFunction.CountIf(Datfield, Range("AY2"))

If WordPos <> 0 Then 'do this if the cell contains the search term

'copy the cell which contains the search term
Datfield.Copy
Sheets("SearchOutput").Range("C1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'copy the corresponding entity name
Worksheets("Database").Cells(Datfield.Row, 3).Copy
Sheets("SearchOutput").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'copy the corresponding task
Worksheets("Database").Cells(Datfield.Row, 14).Copy
Sheets("SearchOutput").Range("B1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Database").Select
End If

CellEmpty: 'jump here if cell is empty
Next Datfield
Application.ScreenUpdating = True
Worksheets("SearchOutput").Select
Range("B1").Select
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With

End Sub


I hope that this insight might help other struggling with the same issue. Thank you again for your replies.

[snb]

This code suffices:

Sub DataCopy()
with Sheets("Database")
For Each cl In .Range("BM7:PO450").specialcells(2)
If cl.Value =.Range("AY2").value Then Sheets("SearchOutput").cells(rows.count,1).End(xlup).Offset(1).resize(,3)=array(.Cells(cl.Row, 14).value,.Cells(cl.Row, 3).value,cl.value)
next
end with
End Sub

[mrjason2008]

Hi snb,

Thank you very much for your reply. It is very impressive that it is possible to shorten the code that much.

Unfortunately, in its current form it does not work for my purposes since it only works for cells that equal the search term in cell AY2. In my case the text strings in each cell are usually much longer than the search term itself, which is why the code would need to look for all cells that contain the search term. In my version, I used Application.WorksheetFunction.CountIf to do so.

Is there a better/more efficient way of checking whether a cell contains a search term?

[Aussiebear]

Check out the InStr() function

[snb]

Sub DataCopy()
With Sheets("Database")
For Each cl In .Range("BM7:PO450").specialcells(2)
If instr(cl.Value,.Range("AY2").value) Then Sheets("SearchOutput").cells(rows.count,1).End(xlup).Offset(1).resize(,3)=array(.Cells(cl.Row, 14).value,.Cells(cl.Row, 3).value,cl.value)
Next
End With
End Sub