Code that checks a sheet and copied found data need some help with excel Macro

Hi,
I have the below code that when data placed in sheet 1 column "A" checks sheet 2 and if found copies to sheet 3

What i want is check sheet 2 and move to sheet 3 if there are more than 1 exact match data

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
mtthompsonsAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

byundtMechanical EngineerCommented:
This question would have benefitted from sample data so we can test the modified code. In its absence, I invented some data and the following macro appears to work as requested.
Sub kTest()
    
    Dim Sht1URLs As Variant
    Dim i As Long, n As Long, nMatches As Long
    Dim r As Range, rBase As Range, rngURL As Range
    Dim URL As String
    
    Set rngURL = Sheet1.Range("A1").CurrentRegion.Resize(, 1)
    Sht1URLs = rngURL.Value2
    Set rBase = Sheet2.UsedRange
    
    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 = rBase.Find(URL, , , 1, 1)
            If Not r Is Nothing Then
                If rBase.FindNext(r).Address <> r.Address Then
                    n = n + 1
                    r.EntireRow.Copy Sheet3.Cells(n, 1)
                    Set r = Nothing
                End If
            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
End Sub

Open in new window


Are you running the macro from an application other than Excel? I ask because it is unusual to replace the named constants with their integer values in statements. You have to do that when running a macro from another application, but it isn't required if you run it from Excel--and the code is a lot easier to understand if you use named constants.
.SpecialCells(4).Delete -4159       'What you had
.SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft       'The usual way of doing it

Open in new window

0
mtthompsonsAuthor Commented:
Thank you

I tried now and no rows are copied to sheet 3

Sheet 1 column "A" i have words like

Some day is mine
Day is mine
What is this report
Some day is mine

Sheet 2 i have 9 columns of data and any column cell can have this words

If the sentence is found in sheet 2 then copy the rows to sheet 3

The above is what exactly the old code does but now if you can see "Some day is mine" this is mentioned in row 1 and 4 so the new change is that 2 rows for this case should be copied
0
byundtMechanical EngineerCommented:
Could you please post a workbook with sample data and expected results?

I will try guessing what you want once again, but it would be very clear with a sample workbook.
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

byundtMechanical EngineerCommented:
Here is my current guess as to what you want:
1. Column A of Sheet1 contains URLs. These URLs are text, and may contain leading or trailing spaces.
2. Search Sheet2 for each URL found in column A of Sheet1
3. Sheet2 will not contain leading or trailing spaces
4. If there is no match for the URL on Sheet2, then color the cell on Sheet1 yellow
5. If there are one or more occurrences on Sheet1 for an URL, then look for a corresponding number of matches on Sheet2. Copy the entire row of the Sheet2 match to Sheet3.
6. If there aren't enough matches for the URL on Sheet2, then do nothing.

Potential pitfall: If an URL appears in two or more places in Sheet1 column A but those places differ with number or location of spaces, then you will get multiple copies of the same row copied over.
Sub kTest()
    
    Dim Sht1URLs As Variant
    Dim i As Long, ii As Long, n As Long, nMatches As Long, rowIndex As Long
    Dim r As Range, rBase As Range, rngURL As Range
    Dim addr As String, URL As String
    
    Set rngURL = Sheet1.Range("A1").CurrentRegion.Resize(, 1)
    Sht1URLs = rngURL.Value2
    Set rBase = Sheet2.UsedRange
    
    Application.ScreenUpdating = 0
    For i = 1 To UBound(Sht1URLs, 1)
        URL = Sht1URLs(i, 1)
        If Len(Sht1URLs(i, 1)) Then
            nMatches = Application.CountIf(rngURL, URL)
            rowIndex = Application.Match(URL, rngURL, 0)
            URL = Application.WorksheetFunction.Trim(URL)
            Set r = rBase.Find(URL, , , 1, 1)
            If r Is Nothing Then
                rngURL.Cells(i, 1).Interior.Color = 65535
            Else
                addr = r.Address
                If rowIndex = i Then
                    For ii = 1 To nMatches
                        n = n + 1
                        r.EntireRow.Copy Sheet3.Cells(n, 1)
                        Set r = rBase.FindNext(r)
                        If r.Address = addr Then Exit For
                    Next
                End If
            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
End Sub

Open in new window

CopyMatchingRowsQ28252329.xlsm
0
mtthompsonsAuthor Commented:
The only issue i have is
Column "A" sheet 1 has one URL
Sheet 2 has the same URL many times
So sheet 3 should get all found rows of the match into sheet 3

Which is not happening rather its getting just once
0
byundtMechanical EngineerCommented:
mtthompsons,
[rant]I must apologize for seemingly floundering around. Usually, I get the answer right with my first post, but in this thread I'm still trying to guess what your question is. You are not asking it in precise terms, and have not provided a sample workbook showing the desired results. Nor have you clarified my numbered summary (points 1 through 6 in my previous Comment) about what you want. [/rant]

If my code below is not working, please correct my understanding of your problem below:
1. Column A of Sheet1 contains URLs. These URLs are "sentences", and may contain extra spaces before, after or in the middle of the text..
2. Search Sheet2 for each URL found in column A of Sheet1
3. Sheet2 will not contain leading or trailing spaces. Sheet2 will use only one space between words.
4. If there is no match for the URL on Sheet2, then color the cell on Sheet1 yellow
5. If there are one or more matches on Sheet2 for an URL, copy the entire row of each Sheet2 match to Sheet3.
6. If an URL occurs more than once on Sheet1, list duplicate copies of matching rows from Sheet2 on Sheet3.

Sub kTest()
Dim Sht1URLs As Variant
Dim i As Long, ii As Long, n As Long, nMatches As Long
Dim r As Range, rBase As Range, rngURL As Range
Dim addr As String, URL As String

Set rngURL = Sheet1.Range("A1").CurrentRegion.Resize(, 1)
Sht1URLs = rngURL.Value2
Set rBase = Sheet2.UsedRange

Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
    If Len(Sht1URLs(i, 1)) Then
        URL = Application.WorksheetFunction.Trim(Sht1URLs(i, 1))
        nMatches = Application.CountIf(rBase, URL)
        Set r = rBase.Find(URL, , , 1, 1)
        If r Is Nothing Then
            rngURL.Cells(i, 1).Interior.Color = 65535
        Else
            addr = r.Address
            For ii = 1 To nMatches
                n = n + 1
                r.EntireRow.Copy Sheet3.Cells(n, 1)
                Set r = rBase.FindNext(r)
                If r.Address = addr Then Exit For
            Next
        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
End Sub

Open in new window

0
mtthompsonsAuthor Commented:
Thanks a lot works perfect and sorry for the confusion where i was not clear

The column "A" content in sheet 1 if its a too long URL the script does not find those in sheet 2
Any help fixing it
300 to 500 characters or more they are skipped
0
byundtMechanical EngineerCommented:
The limit is actually 255 characters. Any more than that, and there will be a runtime error using worksheet functions MATCH and COUNTIF. Furthermore, the Find method won't find them. As a workaround, I changed the macro to search Sheet2 cell by cell when the length of URL is 256 or larger.
Sub kTest()
Dim Sht1URLs As Variant
Dim i As Long, ii As Long, n As Long
Dim cel As Range, r As Range, rBase As Range, rngURL As Range
Dim addr As String, URL As String

Set rngURL = Sheet1.Range("A1").CurrentRegion.Resize(, 1)
Sht1URLs = rngURL.Value2
Set rBase = Sheet2.UsedRange

Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
    URL = Application.WorksheetFunction.Trim(Sht1URLs(i, 1))
    Select Case Len(URL)
    Case 1 To 255
        Set r = rBase.Find(URL, , , 1, 1)
        If r Is Nothing Then
            rngURL.Cells(i, 1).Interior.Color = 65535
        Else
            addr = r.Address
            Do
                n = n + 1
                r.EntireRow.Copy Sheet3.Cells(n, 1)
                Set r = rBase.FindNext(r)
                If r.Address = addr Then Exit Do
            Loop
        End If
    Case Is > 255
        For Each cel In rBase.Cells
            If cel.Value = URL Then
                n = n + 1
                cel.EntireRow.Copy Sheet3.Cells(n, 1)
            End If
        Next
    End Select
Next
'if you need to align the urls in first column
With Sheet3.UsedRange
    On Error Resume Next
    .SpecialCells(4).Delete -4159
End With
End Sub

Open in new window

0
mtthompsonsAuthor Commented:
Thanks
Will check now
Sheet 1 and sheet 2 can i have 94,000 rows of data?
Or does the script have a limit?
0
byundtMechanical EngineerCommented:
There is no limit on amount of data, but it may take a while for the macro to run because it needs to check through each cell in the 90,000 rows.

If the runtime were unacceptably long, there may be some things I could do to speed it up. For example, I could check only the first 255 characters in the URL for a match. Or I could stop searching cells in a row if there is already a match in that row. Or I could bring all the data into VBA and perform the search there.
0
mtthompsonsAuthor Commented:
Limit i mean i have 570 cells in column "A" sheet 1

Sheet 2 has 90K rows of data

For some reason all are not checked

Sheet 1 500 wows are checked with sheet 2 but many come out as not found and mostly those are in sheet 2 in the bottom rows
0
byundtMechanical EngineerCommented:
If you have a blank row in Sheet1 with data below it, the values in column A below the blank row won't be checked. I can overcome that by using a different way of setting the range rngURL in statement 7:
Sub kTest()
Dim Sht1URLs As Variant
Dim i As Long, ii As Long, n As Long
Dim cel As Range, r As Range, rBase As Range, rngURL As Range
Dim addr As String, URL As String

Set rngURL = Range(Sheet1.Range("A1"), Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp))
Sht1URLs = rngURL.Value2
Set rBase = Sheet2.UsedRange

Application.ScreenUpdating = 0
For i = 1 To UBound(Sht1URLs, 1)
    URL = Application.WorksheetFunction.Trim(Sht1URLs(i, 1))
    Select Case Len(URL)
    Case 1 To 255
        Set r = rBase.Find(URL, , , 1, 1)
        If r Is Nothing Then
            rngURL.Cells(i, 1).Interior.Color = 65535
        Else
            addr = r.Address
            Do
                n = n + 1
                r.EntireRow.Copy Sheet3.Cells(n, 1)
                Set r = rBase.FindNext(r)
                If r.Address = addr Then Exit Do
            Loop
        End If
    Case Is > 255
        For Each cel In rBase.Cells
            If cel.Value = URL Then
                n = n + 1
                cel.EntireRow.Copy Sheet3.Cells(n, 1)
            End If
        Next
    End Select
Next
'if you need to align the urls in first column
With Sheet3.UsedRange
    On Error Resume Next
    .SpecialCells(4).Delete -4159
End With
End Sub

Open in new window


If you believe that matches exist in Sheet2 but aren't being found, then I'd need to see a sample workbook that reproduces the problem to figure out how to get around the issue.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
mtthompsonsAuthor Commented:
Thanks a lot for such patient help
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.