[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 776
  • Last Modified:

Excel macro to find all instances of text,select the cell and the next 3 lower cells, cut and transpose to another cell

Hello,

I would like to create an Excel macro, or just a one time sequence, to find all instances of some text, select the cell and the next 3 lower cells, cut and transpose to another cell

Thanks,
Matt
0
mbromb
Asked:
mbromb
  • 4
  • 4
1 Solution
 
Shahid ThaikaSole ProprietorCommented:
Why don't you just use the in-built find feature. You can do 'Find All' to highlight all the found cells and then you can Right click, say copy/cut and then paste it into your other sheet.
0
 
mbrombAuthor Commented:
I can find all, but then I need to select the 4 cells below, cut/paste them adjacent to the originally selected cell.  i can't do that AFAIK with the Find.
0
 
Shahid ThaikaSole ProprietorCommented:
Ah! In that case, in a loop find every case of your text (Record a macro, if you don't know how). The find will either return false or the range of the found cell. Next you can use VBA's offset function to copy-paste.
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
mbrombAuthor Commented:
what I have right now is a macro that does a single instance.  Then i can hit a shortcut key 70 times to have it do the rest of the instances.  If I hit it shortcut one too many times it starts again at the top and screws up the doc, and there seems to be no way to undo a macro change.
0
 
Shahid ThaikaSole ProprietorCommented:
That's why you need to put it in a loop. I'd help more, but I currently don't have access to Excel and whatever I am saying is from the top of my head. You can do something like...

While(Sheet1.Find("Something", Direction:=TopDown) = True)
    Selection.Offset(1, 0).Copy NewRange
    Selection.Offset(2, 0).Copy NewRange
    Selection.Offset(3, 0).Copy NewRange
Wend


Make sure you give all the parameters in the Find function, including those to search in one direction (top-down) and the parameter that finds the next instances only. Then your macro will not start from the beginning.
0
 
mbrombAuthor Commented:
Here's the macro code.  I'm not sure how to incorporate the loop.


----------------------------------------------------
Sub store()
'
' store Macro
'
' Keyboard Shortcut: Ctrl+t
'
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Cells.Find(What:="store:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Range("A1:A5").Select
    Selection.Copy
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(1, 0).Rows("1:5").EntireRow.Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub
----------------------------------------------------
0
 
Shahid ThaikaSole ProprietorCommented:
Perhaps something like this solves your purpose.
Sub store()
'
' store Macro
'
' Keyboard Shortcut: Ctrl+t
'
    Dim sRow As Double
    
    On Error GoTo Err
    
    ActiveCell.Offset(-1, 0).Range("A1").Select
    
    While (Cells.Find(What:="store:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate)

        'check if we are resuming again from top (We don't want this)
        If ActiveCell.Row <= sRow Then Exit Sub
        If sRow = 0 Then sRow = ActiveCell.Row

        ActiveCell.Offset(1, 0).Range("A1:A5").Select
        Selection.Copy
        ActiveCell.Offset(-1, 1).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        ActiveCell.Offset(1, 0).Rows("1:5").EntireRow.Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp
    Wend
        Exit Sub
Err:
        Debug.Assert False
        Resume Next
End Sub

Open in new window

0
 
mbrombAuthor Commented:
i didn't have any luck with the script and unfortunately I've had to drop this.
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now