Find text in column A and past Column D of that row into new worksheet?

[silentwolf]

Hi guys,
I am looking for a code to find a part of an text in column A but copy Column D from that the row of that found cell into a new worksheet.

I have been looking for codes but can't seam to find the right one for my needs.

Would be much appreciated if someone can give me a help with this.

Many thanks

SW

 

[L. Howard]

Hi SW,

Give this a try.

Set myWord to the word you are searching for, and adjust sheet numbers/names/range to suit.

Code finds "dum" in column A of sheet 2 and copies D column cell to column F on sheet 3.

Howard

Option Explicit

Sub WordWork()
Dim c As Range
Dim myWord As String
myWord = "dum"

For Each c In Sheets("Sheet2").Range("A1", Range("A1").End(xlDown))
    If InStr(c, myWord) > 0 Then
     c.Offset(, 3).Copy Sheets("Sheet3").Range("F" & Rows.Count).End(xlUp)(2)
  End If
Next

End Sub

 

[silentwolf]

Hi Howard,

many thanks for your reply!
I am getting there the only thing is following...
1. The name is not unique there are Names like "Gesamtbetrag netto" but also "Gesamtbetrg brutto" so I would like to be able to have all of them copied
2. There are formulas in the column so how do I have to paste it so the value shows.

I will try to make it work

Many thanks to you!!

Nice weekend
Albert

 

[L. Howard]

Hi Albert,

Maybe this will be a step in the right direction.

Enter the word you want to search for in cell H1. The code will look for matches of the first 5 letters of that word and paste the values of the offsets.

If you have several words to search for, it is possible to list them and have the code refer to the list during the search and return values for all in the list.

We can also change the number of letters for the search word if needed.

Howard

Sub WordWork()
Dim c As Range
Dim myWord As String
myWord = Left(Range("H1"), 5)

For Each c In Sheets("Sheet2").Range("A1", Range("A1").End(xlDown))
    If InStr(c, myWord) > 0 Then
     c.Offset(, 3).Copy
     Sheets("Sheet3").Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
  End If
Next

End Sub

 

[silentwolf]

Hi Howard,
many thanks for your reply!
Just wondering is it possible to copy myword also into the worksheet? And could there be more search criterias and copy and paste them to?

Great work by the way !!
Nice sunday

Albert

 

[L. Howard]

Hi Albert,

Something like this?

Sub PartWordWork()
Dim c As Range
Dim myWord As String

myWord = Left(Range("H1"), 5)

For Each c In Sheets("Sheet2").Range("A1", Range("A1").End(xlDown))
    If InStr(c, myWord) > 0 Then
     Sheets("Sheet3").Range("G" & Rows.Count).End(xlUp)(2) = myWord & " " & c.Offset(, 3)
  End If
Next

End Sub

Just wondering is it possible to copy myword also into the worksheet? And could there be more search criterias and copy and paste them to?
Albert

What would be the additional criteria to copy?

Howard

 

[silentwolf]

Hi Howard,
thanks again! But unfortunatelly that is not what I am after..
I was just wondering if the myword in Cell H1 can also be copied into the sheet3 but in a different column as the offset.
So I can see the word I am looking for also in the sheet3
Also I was wondering if there can be more criterias maybe in different cells also as a lookup G1 or so and then copy and paste them also in the new sheet3
So I end up in sheet3 Column A myword Column B myword-offset Column C myword2 D myword-offset and so on...
Is that possible and hope you can understand what I am after

 

[L. Howard]

Try this, with the search words listed in H1, H2 & H3

Howard

Sub PartWordWork()
Dim c As Range
Dim myWord1 As String, myWord2 As String, myWord3 As String

myWord1 = Left(Range("H1"), 5)
myWord2 = Left(Range("H2"), 5)
myWord3 = Left(Range("H3"), 5)
Application.ScreenUpdating = False

For Each c In Sheets("Sheet2").Range("A1", Range("A1").End(xlDown))
   If InStr(c, myWord1) > 0 Then
       c.Offset(, 3).Copy
       Sheets("Sheet3").Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
       Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp)(2) = Sheets("Sheet2").Range("H1")
     ElseIf InStr(c, myWord2) > 0 Then
       c.Offset(, 3).Copy
       Sheets("Sheet3").Range("D" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
       Sheets("Sheet3").Range("C" & Rows.Count).End(xlUp)(2) = Sheets("Sheet2").Range("H2")
     ElseIf InStr(c, myWord3) > 0 Then
       c.Offset(, 3).Copy
       Sheets("Sheet3").Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
       Sheets("Sheet3").Range("E" & Rows.Count).End(xlUp)(2) = Sheets("Sheet2").Range("H3")
   End If
Next

Application.ScreenUpdating = True
End Sub