Copy Data From One Sheet to Another with Input Box

[Loss1003]

I found the following code to Copy Data From One Sheet to Another with Input Box however the code runs extremely slow because it bounces back an forth the two sheets searching thru every row. Please help me to speed up the code.


Sub copy_paste_data_from_one_sheet_to_another()
'Let's start at row 2. Row 1 has headers
Sheet4.Activate
x = 2
Dim myName As String
myName = Application.InputBox("Enter a name")
'Worksheets("Sheet1").Activate
'Start the loop
Do While Cells(x, 27) <> ""
'Look for name
If Cells(x, 27) = myName Then
'copy the row if it contains 'myName'
Worksheets("Payment Upload").Rows(x).Copy
'Go to sheet2. Activate it. We want the data here
Worksheets("Sheet3").Activate
'Find the first empty row in sheet2
erow = Sheet10.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Paste the data here
Application.DisplayAlerts = False
ActiveSheet.Paste Destination:=Worksheets("Sheet3").Rows(erow)
Application.DisplayAlerts = True
End If
'go to sheet1 again and actvate it
Worksheets("Payment Upload").Activate
'Loop through the other rows with data
x = x + 1
Loop
End Sub

[Kenneth Hobs]

Here are my speedup tips: http://vbaexpress.com/kb/getarticle.php?kb_id=1035

Your code is hard to follow as you are using both sheet code names and sheet names. I recommend using one or the other.

There is seldom a need to use Select or Activate.

My general solution would be to use a FindAll() routine.


' Chip Pearson, http://www.cpearson.com/excel/FindAll.aspx

'Kenneth, http://www.vbaexpress.com/forum/showthread.php?t=38802
Sub Test_FoundRanges()
Dim findRange As Range, findString As String, foundRange As Range
Dim r As Range, i As Long
On Error GoTo EndNow:
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn
Set findRange = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
findString = "Allocation"
Set foundRange = FoundRanges(findRange, findString)
If foundRange Is Nothing Then GoTo EndNow
'If Not foundRange Is Nothing Then MsgBox foundRange.Address 'Note that range is in reverse order
'If Not foundRange Is Nothing Then foundRange.EntireRow.Delete
'For i = i to foundRange.Areas.Count
'foundRange.Areas(i).EntireRow.Delete
'Next i
EndNow:
SpeedOff
End Sub


Function FoundRanges(fRange As Range, fStr As String) As Range
Dim objFind As Range
Dim rFound As Range, FirstAddress As String
With fRange
Set objFind = .Find(What:=fStr, after:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=True)
If Not objFind Is Nothing Then
Set rFound = objFind
FirstAddress = objFind.Address
Do
Set objFind = .FindNext(objFind)
If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
End If
End With
Set FoundRanges = rFound
End Function