Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 402
  • Last Modified:

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

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
bsharath
Asked:
bsharath
  • 4
  • 4
1 Solution
 
krishnakrkcCommented:
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

Open in new window


Kris
0
 
bsharathAuthor Commented:
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
 
krishnakrkcCommented:
It is searching for an exact match. Try to replace this line

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

Open in new window


with

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

Open in new window


Kris
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
bsharathAuthor Commented:
Yes i want the exact match
What does the above change do?
0
 
krishnakrkcCommented:
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

Open in new window


Kris
0
 
bsharathAuthor Commented:
If the URl has a start and end space it ignores

Can this be dealt?
0
 
krishnakrkcCommented:
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

Open in new window


Kris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now