Excel/ VBA: Problem 1

[SBuzzT]

Here is a screenshot of the problem: The row I circled is how I need it to look, however if the search value appears on several pages, I get a new row for each page instead of just 1 row with all the results.

Here is the code:

Sub Lookup()

Dim rng As Range, Cel, ms As Worksheet, ws As Worksheet, k, NR&

Set ms = Sheets("LOOKUP")

Application.ScreenUpdating = 0

Sheets("LOOKUP").Range("B3:D6").ClearContents

     With ms
       Cel = .Range("B2")
     End With
     
     For Each ws In ThisWorkbook.Worksheets

         If ws.Name <> ms.Name Then
        
            With ws.UsedRange
            
                    If Len(Cel) Then
                          
                            Set rng = .Find("*" & Cel & "*", LookIn:=xlValues, LookAt:=xlWhole)
                                                                                                                                                              
                               If Not rng Is Nothing Then
                                    k = k & "," & ws.Name
                                    rng.Offset(, -13).Copy
                                    NR = ms.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                                    ms.Range("B" & NR).PasteSpecial xlValues
                                    rng.Copy
                                    ms.Range("C" & NR).PasteSpecial xlValues
                                    ms.Range("D" & NR) = Mid(k, 2)
                               End If
                                                                                                                                                          
                    End If
     
            End With
  End If
 Next
 
   'If Range("B3").Value = "" Then MsgBox ("Number " & Cel & " not found.")
   
   'ms.Range("F" & NR) = Mid(k, 2)
 
Application.CutCopyMode = 0
Set ms = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
End Sub

 

[SkipVought]

move the assignment for NR prior to your loop

'
    Cel = ms.Range("B2")
[b]         
    [highlight]NR = ms.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1[/highlight]
[/b]    
    For Each ws In ThisWorkbook.Worksheets

        If ws.Name <> ms.Name Then
       
           With ws.UsedRange
           
               If Len(Cel) Then
                     
                   Set rng = .Find("*" & Cel & "*", LookIn:=xlValues, LookAt:=xlWhole)
                             
                   If Not rng Is Nothing Then
                        k = k & "," & ws.Name
                        rng.Offset(, -13).Copy
                        ms.Range("B" & NR).PasteSpecial xlValues
                        rng.Copy
                        ms.Range("C" & NR).PasteSpecial xlValues
                        ms.Range("D" & NR) = Mid(k, 2)
                   End If
                                                                                                                                                     
               End If
    
           End With
       End If
    Next

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[SBuzzT]

Wow! That actually a little embarrassing... LOL

Thanks a bunch for the quick answer Skip.