Solved

# Sheet 1 column URL's if found in sheet 2 any columns . Copy full rows to sheet 3

Posted on 2013-01-10
Medium Priority
391 Views
Sheet 1 column URL's if found in sheet 2 any columns . Copy full rows to sheet 3
Attached file
Need a macro that can do this
Copy-rows.xls
0
Question by:bsharath
[X]
###### Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points
• 4
• 4

LVL 18

Expert Comment

ID: 38766196
Hi

try
``````Sub kTest()

Dim Sht1URLs, i   As Long, r As Range, n As Long

Sht1URLs = Sheet1.Range("a1").CurrentRegion.Resize(, 1).Value2
Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
If Len(Sht1URLs(i, 1)) Then
Set r = Sheet2.UsedRange.Cells.Find(Sht1URLs(i, 1), , , 1)
If Not r Is Nothing Then
n = n + 1
r.EntireRow.Copy Sheet3.Cells(n, 1)
Set r = Nothing
End If
End If
Next
'if you need to align the urls in first column
With Sheet3.UsedRange
On Error Resume Next
.SpecialCells(4).Delete -4159
End With
Application.ScreenUpdating = 1
End Sub
``````

Kris
0

LVL 11

Author Comment

ID: 38766231
Perfect

there were 200 that were not moved

Can the sheet 1 have a color set to ones that were not moved

So i know what the issue was with them?
0

LVL 18

Expert Comment

ID: 38766271
It is searching for an exact match. Try to replace this line

``````Set r = Sheet2.UsedRange.Cells.Find(Sht1URLs(i, 1), , , 1)
``````

with

``````Set r = Sheet2.UsedRange.Cells.Find(Sht1URLs(i, 1), , , 2)
``````

Kris
0

LVL 11

Author Comment

ID: 38766283
Yes i want the exact match
What does the above change do?
0

LVL 18

Expert Comment

ID: 38766307
That looks a partial match.

anyway try this one.

``````Sub kTest()

Dim Sht1URLs, i   As Long, r As Range, n As Long, rngURL    As Range

Set rngURL = Sheet1.Range("a1").CurrentRegion.Resize(, 1)
Sht1URLs = rngURL.Value2

Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
If Len(Sht1URLs(i, 1)) Then
Set r = Sheet2.UsedRange.Cells.Find(Sht1URLs(i, 1), , , 1)
If Not r Is Nothing Then
n = n + 1
r.EntireRow.Copy Sheet3.Cells(n, 1)
Set r = Nothing
Else
rngURL.Cells(i, 1).Interior.Color = 65535
End If
End If
Next
'if you need to align the urls in first column
With Sheet3.UsedRange
On Error Resume Next
.SpecialCells(4).Delete -4159
End With
Application.ScreenUpdating = 1
End Sub
``````

Kris
0

LVL 11

Author Comment

ID: 38766334
If the URl has a start and end space it ignores

Can this be dealt?
0

LVL 18

Accepted Solution

krishnakrkc earned 2000 total points
ID: 38766339
try

``````Sub kTest()

Dim Sht1URLs, i   As Long, r As Range, n As Long
Dim rngURL    As Range, URL As String

Set rngURL = Sheet1.Range("a1").CurrentRegion.Resize(, 1)
Sht1URLs = rngURL.Value2

Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
If Len(Sht1URLs(i, 1)) Then
URL = Application.WorksheetFunction.Trim(Sht1URLs(i, 1))
Set r = Sheet2.UsedRange.Cells.Find(URL, , , 1)
If Not r Is Nothing Then
n = n + 1
r.EntireRow.Copy Sheet3.Cells(n, 1)
Set r = Nothing
Else
rngURL.Cells(i, 1).Interior.Color = 65535
End If
End If
Next
'if you need to align the urls in first column
With Sheet3.UsedRange
On Error Resume Next
.SpecialCells(4).Delete -4159
End With
Application.ScreenUpdating = 1
End Sub
``````

Kris
0

LVL 11

Author Comment

ID: 38766349
0

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
###### Suggested Courses
Course of the Month10 days, 8 hours left to enroll