Find value one at a time in all possible location and paste value corresponding to the value..

[VBABEGINER]

Hello Message Board,

From very long duration, Come back again to post the query. I hope everyone do well. okk..

I have written my code in Workbook 3.

In Workbook 2 I have multiple row repeated data in column A. example of data..

table abc pqr xzy
qwe chair poi lkjhgfdd ert
bhg fgdtrs table kjl re wwww
poi lkj dfg sdf chair
dfg fan asd
fan iu opi

In Workbook 1 I have master data.

Column A.....Column B
Table...........Lamp
Chair...........Man
Fan.............Air



Now, my query is..

Based on book 1 value, it find the values in Col A of Work book 2. Once the record finds, it paste the corresponding value in Col B of Workbook 2.

Example,

"Table" (cell A2) copy. go to book 2. finds all the "Table" in Col A. and paste "Lamp" (cell B2) value in front of

"table abc pqr xzy"
"bhg fgdtrs table kjl re wwww".


I hope I have clear my question.

I have did my code, but it finds only one record. I'm unable to do for find value one at a time all and paste value one at a time.

Please help me to get the code please.

 

[VBABEGINER]

Sharing my code as well,

Public Function fnFindtext()


Workbooks("Book1").Activate
Dim CountRowBk1 As Integer
Dim k As Integer 'k for counting total worksheets


For k = 1 To Worksheets.Count
Worksheets.Item(k).Activate
If Worksheets.Item(k).Name <> "Sheet6" Then
Else
CountRowBk1 = Range("A" & Rows.Count).End(xlUp).Row

'opening another workbook
Workbooks.Open "C:\Users\PUTEKAR\Book2.xlsx"
Dim CountRowBk2 As Integer
Dim FndTxt As String
Dim txt As String

CountRowBk2 = 1

Do Until Cells(CountRowBk2, 1) = ""

FndTxt = Cells(CountRowBk2, 1).Value

Workbooks("Book1").Activate
Range(Cells(1, 1), Cells(CountRowBk1, 1)).Select
txt = Selection.Find(What:=FndTxt, After:=ActiveCell, LookIn:=xlFormulas, lookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row

Workbooks("Book2").Activate
Cells(CountRowBk2, 2).Select
Selection.Copy

Workbooks("Book1").Activate
Cells(txt, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'---
CountRowBk2 = CountRowBk2 + 1
Loop
Workbooks("Book2").Close
End If
Next k
End Function

 

[ww4612]

do you have problem to copy and paste value only? if you do not need to paste any other things like format and hyperlink. you can out put the cell value into a variable before transfer it to another cell value. like this

dim a as string
a=sheets(1).cells(1,1).value
sheets(2).cells(1,1).value=a

if you want to transfer value from a range, you can output the array into a variant, like the following

dim v as variant
with sheets(1)
v=range(.cells(1,1),cells(10,10))
end with
with sheets(2)
range(.cells(2,1),cells(11,10))=v
end with

 

[VBABEGINER]

Hi,
Thank You for replying.

But honestly Im not getting what u trying to said. First of all, I am using 3 workbooks not worksheets.

Code lies in book3, complex data lies in book2 and master data lies in book1. copy book1 value and find it in book2. now in book2, it may be single record find or multiple. Whatever no of records find, it paste the value.

do you have problem to copy and paste value only? if you do not need to paste any other things like format and hyperlink. you can out put the cell value into a variable before transfer it to another cell value. like this

dim a as string
a=sheets(1).cells(1,1).value
sheets(2).cells(1,1).value=a

if you want to transfer value from a range, you can output the array into a variant, like the following

dim v as variant
with sheets(1)
v=range(.cells(1,1),cells(10,10))
end with
with sheets(2)
range(.cells(2,1),cells(11,10))=v
end with

 

[VBABEGINER]

Ohkk...seems I'm unable to present you properly.

At least tell me someone, do we find multiple records in one line of code? - If yes,

Then, can we paste our copied value in all the cell which ever we finds?

Please.

 

[ww4612]

transfer value in among sheets is same as transfer value among workbooks. the only different is that you have to put the code into a module if you cord must run among several workbooks.

give me sometime. i will try to rewrite the code.
based on your expression, what you need is like a cross workbook vlookup function. am i right?

 

[VBABEGINER]

yes

 

[ww4612]

Dim r As Integer, rg As Range, s As String, r1 As Integer
r = 1
With Workbooks("Book2").Sheets(1)
Do
    fndtxt = Workbooks("Book1").Sheets(1).Cells(r, 1).Value
        Set rg = Range(.Cells(1, 1), .Cells(CountRowBk1, 1)).Find(what:=fndtxt, lookAt:=xlWhole)
        If Not rg Is Nothing Then
            .Cells(rg.Row, 2).Value = Workbooks("Book1").Sheets(1).Cells(r, 2).Value
        End If
        r = r + 1
    
Loop Until .Cells(r, 1).Value = NullString
End With

i did not test this code yet. can this code solve your problem?
and remember to put the code into a module not a sheet.
sorry i just made a mistake. i have corrected it

 

[VBABEGINER]

Hi,
Slight change in code...and inserting my comment to get the right information.

Dim r As Integer, rg As Range, s As String, r1 As Integer

r = 1
Do
FndTxt = Workbooks("Book2").Sheets(1).Cells(r, 1).Value
With Workbooks("Book1").Sheets(7)
Set rg = Range(.Cells(1, 1), .Cells(CountRowBk1, 1)).Find(what:=FndTxt, lookAt:=xlPart)
If Not rg Is Nothing Then
With Workbooks("Book2").Sheets(1).Cells(r, 2).Select

'here I require if the value finds then, from book2 copy the value infront of r value and paste besides to book1. i.e. in Col B. (note, here there are multiple r values also. Then how did there we can paste the data.) because, this loop mooving to next r value. It should find another value in range "Cells(1, 1), .Cells(CountRowBk1, 1)" and find again if there exist, "FndTxt"

'--I believe I'm able to try to explain.


.Cells(rg.Row, 2).Value = rg.Value

End If
r = r + 1
End With
Loop Until Cells(r, 1).Value = "" 'NullString

Dim r As Integer, rg As Range, s As String, r1 As Integer
r = 1
With Workbooks("Book2").Sheets(1)
Do
    fndtxt = Workbooks("Book1").Sheets(1).Cells(r, 1).Value
        Set rg = Range(.Cells(1, 1), .Cells(CountRowBk1, 1)).Find(what:=fndtxt, lookAt:=xlWhole)
        If Not rg Is Nothing Then
            .Cells(rg.Row, 2).Value = Workbooks("Book1").Sheets(1).Cells(r, 2).Value
        End If
        r = r + 1
    
Loop Until .Cells(r, 1).Value = NullString
End With

i did not test this code yet. can this code solve your problem?
and remember to put the code into a module not a sheet.
sorry i just made a mistake. i have corrected it