Macro to be created

[vishal005]

Hi Guys,

I need help with the macro,

I have excel sheet which contains data in more than 4500 colums and 15000 rows.


I want a macro which will search a word of my choice in excel and if it found then the macro will copy that word along with cell which is adjucent to that cell (Left cell and Right cell) in other excel.

There are chances that specific word may exists in my excel for more than 2000 times.

 

[NoSparks]

Not knowing where you're looking nor where you want the results, maybe something along the lines of this ?

Sub FindingTheWord()
    Dim WordToFind As Range
    Dim firstAddress As String
    Dim lookfor As String
    Dim nextRow As Long
    
'the word to look for
lookfor = InputBox("Input the word to search for")
Application.ScreenUpdating = False
'look for it on "Sheet1"
    With Sheets("Sheet1").UsedRange
        Set WordToFind = .Find(lookfor, LookIn:=xlValues)
        'if the word is found
        If Not WordToFind Is Nothing Then
            'note where first occurance is to prevent wrap around
            firstAddress = WordToFind.Address
            'copy appropriate stuff to "Sheet2"
            nextRow = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
            Sheets("Sheet2").Cells(nextRow, 1).Resize(1, 3).Value = WordToFind.Offset(0, -1).Resize(1, 3).Value
            'find this word again until there isn't any
            Do
                Set WordToFind = .FindNext(WordToFind)
                nextRow = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
                Sheets("Sheet2").Cells(nextRow, 1).Resize(1, 3).Value = WordToFind.Offset(0, -1).Resize(1, 3).Value
            Loop While Not WordToFind Is Nothing And WordToFind.Address <> firstAddress
        Else
            MsgBox "The word " & Chr(34) & lookfor & Chr(34) & " was not found"
        End If
    End With
Application.ScreenUpdating = True
End Sub

 

[vishal005]

Thanks Mate,

The data is in sheet called sheet1 and i want results in new excel sheet.

Also in my data there are word which appears in one row for more than one time

In your current macro i an getting error in below row'

Sheets("Sheet2").Cells(nextRow, 1).Resize(1, 3).Value = WordToFind.Offset(0, -1).Resize(1, 3).Value

 

[vishal005]

mate the code work fine thanks,

Can you modify the code little i want the macro to extract some more details if the word is found in row then apart from the adjucent cells the macro should pick up details located in row which header called "date of Gift", description, status and requester

 

[NoSparks]

Can you make a sample (de-sensitized) workbook available indicative of what you are working with and showing an example result of what you are after ?

 

[vishal005]

No worries mate,

Can you just modify the macro in such away that apart from the information which I ma getting right now it will also provide me the row number at each found instant

 

[vishal005]

to give you exact details the macro should pick up values from columns L,M,N,O from similar row from where its picked up the previous value and should past it next to details which macro has extracted in sheet2.

Thanks for your help in advance

 

[NoSparks]

try this

Sub FindingTheWord()
    Dim WordToFind As Range
    Dim firstAddress As String
    Dim lookfor As String
    Dim nextRow As Long
    
'the word to look for
lookfor = InputBox("Input the word to search for")
Application.ScreenUpdating = False
'look for it on "Sheet1"
    With Sheets("Sheet1").UsedRange
        Set WordToFind = .Find(lookfor, LookIn:=xlValues)
        'if the word is found
        If Not WordToFind Is Nothing Then
            'note where first occurance is to prevent wrap around
            firstAddress = WordToFind.Address
            'copy appropriate stuff to "Sheet2"
            nextRow = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
            Sheets("Sheet2").Cells(nextRow, "A").Resize(1, 3).Value = WordToFind.Offset(0, -1).Resize(1, 3).Value
            Sheets("Sheet2").Cells(nextRow, "D").Resize(1, 4).Value = Cells(WordToFind.Row, "L").Resize(1, 4).Value
            'find this word again until back to first found
            Do
                Set WordToFind = .FindNext(WordToFind)
                If WordToFind.Address = firstAddress Then Exit Do
                'copy more stuff to "Sheet2"
                nextRow = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
                Sheets("Sheet2").Cells(nextRow, "A").Resize(1, 3).Value = WordToFind.Offset(0, -1).Resize(1, 3).Value
                Sheets("Sheet2").Cells(nextRow, "D").Resize(1, 4).Value = Cells(WordToFind.Row, "L").Resize(1, 4).Value
            Loop While Not WordToFind Is Nothing And WordToFind.Address <> firstAddress
        Else
            MsgBox "The word " & Chr(34) & lookfor & Chr(34) & " was not found"
        End If
    End With
Application.ScreenUpdating = True
End Sub

 

[vishal005]

fantastic dude you are a rock star

 

[vishal005]

just last favor in sheet2 where we have got the results if the column c contains "Expense", "Approved" or "Pending" then it should delete the entire row.
And if possible can the macro do Trim on row a of sheet 2 after pulling out the details.