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

Rakesh Kumar

New Member
Joined
Apr 26, 2015
Messages
7
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
R1Travel to United states of America and meet St. Martin
R2St. martin is a person name
R3Office having Information Technology Department
R4Go to the human research and development department
R5The treatment is FREE in the Hospital

<tbody>
</tbody>

Data.xlsx
R1United states of AmericaA country Name
R2St. martinName of person
R3Information Technology DepartmentOfficial
R4Human research and developmentMedical Departments
R5treatmenthealth 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
R1Travel to United states of America and meet St. MartinUnited states of America > A country Name
St. martin > Name of person
R2St. martin is a person nameSt. martin > Name of person
R3Office having Information Technology DepartmentInformation Technology Department > Official
R4Go to the human research and development departmentHuman research and development > Medical Departments
R5The treatment is FREE in the Hospitaltreatment > 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
 

Some videos you may like

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Code:
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

New Member
Joined
Apr 26, 2015
Messages
7
Thanks for help but this macro is not work correctly after applying this macro result is


file.xlsx:-

R1Travel to United states of America and meet St. MartinTravel to United states of America and meet St. Martin >
R2St. martin is a person nameSt. martin is a person name >
R3Office having Information Technology DepartmentOffice having Information Technology Department >
R4Go to the human research and development departmentGo to the human research and development department >
R5The treatment is FREE in the HospitalThe treatment is FREE in the Hospital >

<tbody>
</tbody>
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Sorry about that. I forgot to take out the stuff I used for testing. This should produce better results.
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,564
Messages
5,596,875
Members
414,106
Latest member
Tigretto

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top