Macro to Find a value and Keep to next row from another excel with information

[Rakesh Kumar]

Please help me any genious!!!

i have two excel one is file.xlsx and other is data.xlsx data is on sheet 1 on both the excels from R1:C1
like this:-

File.xlsx

R1	Travel to United states of America and meet St. Martin
R2	St. martin is a person name
R3	Office having Information Technology Department
R4	Go to the human research and development department
R5	The treatment is FREE in the Hospital

<tbody>
</tbody>

Data.xlsx

R1	United states of America	A country Name
R2	St. martin	Name of person
R3	Information Technology Department	Official
R4	Human research and development	Medical Departments
R5	treatment	health fitness related

<tbody>
</tbody>

i have to find the exact match from data.xls in file.excel and the output will be after running macro on file.xlsx is like this:-

Output result:-
File.xlsx

R1	Travel to United states of America and meet St. Martin	United states of America > A country Name St. martin > Name of person
R2	St. martin is a person name	St. martin > Name of person
R3	Office having Information Technology Department	Information Technology Department > Official
R4	Go to the human research and development department	Human research and development > Medical Departments
R5	The treatment is FREE in the Hospital	treatment > health fitness related

<tbody>
</tbody>

Please note that search the term from data.xlsx in File.xlsx and output is on file.xlsx

Need Help for implimenting this macro!!!
Really Different.......... and difficult

 

[JLGWhiz]

Sub linkup()
Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range, fAdr As String
'Set wb1 = Workbooks("File.xlsx")
'Set wb2 = Workbooks("Data.xlsx")
Set sh1 = Sheets(1) 'wb1.Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'wb2.Sheets(1) 'Edit sheet name
    With sh2
        For Each c In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh1.Range("A:A").Find(c.Value, , xlValues, xlPart)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    Do
                        If fn.Offset(0, 1) = "" Then
                             fn.Offset(0, 1) = c.Value & " > " & c.Offset(0, 1).Value
                        Else
                            fn.Offset(0, 1) = fn.Offset(0, 1).Value & vbLf & c.Value & " > " & c.Offset(0, 1).Value
                        End If
                        Set fn = sh1.Range("A:A").FindNext(fn)
                    Loop While fn.Address <> fAdr
                    Columns(2).AutoFit
                End If
        Next
    End With
End Sub

 

[Rakesh Kumar]

Thanks for help but this macro is not work correctly after applying this macro result is


file.xlsx:-

R1	Travel to United states of America and meet St. Martin	Travel to United states of America and meet St. Martin >
R2	St. martin is a person name	St. martin is a person name >
R3	Office having Information Technology Department	Office having Information Technology Department >
R4	Go to the human research and development department	Go to the human research and development department >
R5	The treatment is FREE in the Hospital	The treatment is FREE in the Hospital >

<tbody>
</tbody>

 

[JLGWhiz]

Sorry about that. I forgot to take out the stuff I used for testing. This should produce better results.

Sub linkup()
Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range, fAdr As String
Set wb1 = Workbooks("File.xlsx")
Set wb2 = Workbooks("Data.xlsx")
Set sh1 = wb1.Sheets(1) 'Edit sheet name
Set sh2 = wb2.Sheets(1) 'Edit sheet name
    With sh2
        For Each c In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh1.Range("A:A").Find(c.Value, , xlValues, xlPart)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    Do
                        If fn.Offset(0, 1) = "" Then
                             fn.Offset(0, 1) = c.Value & " > " & c.Offset(0, 1).Value
                        Else
                            fn.Offset(0, 1) = fn.Offset(0, 1).Value & vbLf & c.Value & " > " & c.Offset(0, 1).Value
                        End If
                        Set fn = sh1.Range("A:A").FindNext(fn)
                    Loop While fn.Address <> fAdr
                    Columns(2).AutoFit
                End If
        Next
    End With
End Sub

 

[Rakesh Kumar]

Thank you so much its Working now Thanks alot