How to select range between 2 specific words

[mekcsx]

I want to write a macro to select only range area between 2 words.
For example, I have data about 200-300 rows and I just need only the range that located inside the word "[price]" and "[end_price]" as below:

[product]
a
b
c
[end_product]
[price]
1
2
3
[end_price]

How can I write the vba to run this macro to get answer
1
2
3

In addition, other rows else will be removed by paste only for the selected range
Thank you

 

[JLeno]

Sub SelectRange()
With ActiveSheet
    .Range(.Cells.Find("[price]"), .Cells.Find("[end_price]")).Select
End With
    
End Sub

 

[mekcsx]

Thanks very much, JLeno

 

[mekcsx]

Sub SelectRange()
With ActiveSheet
    .Range(.Cells.Find("[price]"), .Cells.Find("[end_price]")).Select
End With
    
End Sub

I got bug when I combine it with my code.
I want to cut the selection(column A) then paste to another column(B) -> ClearContents(A) ->Move them back to A

Sub SelectRange()
With ActiveSheet
.Range(.Cells.Find("[pump_sales]"), .Cells.Find("[end_pump_sales]")).Select
End With
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Range("A2", Selection.End(xlDown)).Select
Selection.ClearContents
Columns("B:B").Select
Selection.Cut
Range("A2", Selection.End(xlDown)).Select
ActiveSheet.Paste

End Sub

 

[L. Howard]

From my archives, modified.

Try this in the sheet module. I used XX and XXX as start and end key words, change to suit.
Or you could put them in K1 and K2 if you uncomment those lines and delete the other two start/end key word lines.

I have mild concerns about doing multiple start and end key words down column A. Copies to column B and back to column A in reverse order.
I'm not sure why. Probably can be fixed if that is a big problem.

Regards,
Howard

Option Explicit
Sub Copy_Twixt_Keywords()
    
    Dim rngKeyWordStart As Range, rngKeyWordEnd As Range
    Dim strKeyWordStart As String, strKeyWordEnd As String, FirstFound As String
    
    'strKeyWordStart = Range("K1").Value
    strKeyWordStart = "XX"  'delete if using K1
    
    'strKeyWordEnd = Range("K2").Value
    strKeyWordEnd = "XXX"  'delete if using K2
    
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart, _
                                                 LookIn:=xlValues, _
                                                 LookAt:=xlWhole, _
                                                 SearchOrder:=xlByRows, _
                                                 SearchDirection:=xlNext, _
                                                 MatchCase:=False)
                                                 
        If Not rngKeyWordStart Is Nothing Then
            
            FirstFound = rngKeyWordStart.Address
                                                     
            Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd, _
                                                   After:=rngKeyWordStart)
    
            If Not rngKeyWordEnd Is Nothing Then
                Do
                   .Range(rngKeyWordStart, rngKeyWordEnd).Copy
                   Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues
                                                                                   
                Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart, _
                                                         After:=rngKeyWordEnd)
                Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd, _
                                                       After:=rngKeyWordStart)
                    
                Loop While rngKeyWordStart.Address <> FirstFound And _
                           rngKeyWordEnd.Row > rngKeyWordStart.Row
            Else
                MsgBox "Cannot find a match for the 'End' keyword: " & _
                        vbLf & """" & strKeyWordEnd & """", _
                        vbExclamation, "No Match Found"
            End If
            
        Else
                MsgBox "Cannot find a match for the 'Start' keyword: " & _
                        vbLf & """" & strKeyWordStart & """", _
                        vbExclamation, "No Match Found"
        End If
            
    End With
    
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
    
Range("A:A").ClearContents
Range("B:B").Copy Range("A1")
Range("B:B").ClearContents

End Sub

 

[L. Howard]

Here is a cleaner version with thanks to Claus of MS Public forum.

Option Explicit

Sub Test2_Claus()
Dim strStart      As String
Dim strEnd        As String
Dim RStart        As Range
Dim REnd          As Range
Dim LRow          As Long
Dim i                As Long

strStart = "XX"
strEnd = "XXX"

i = 1
LRow = Cells(Rows.Count, 1).End(xlUp).Row

Do
  Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
    (strStart, Cells(LRow, 1), xlValues, xlWhole)
  If Not RStart Is Nothing Then
    Set REnd = Range(Cells(i, 1), Cells(LRow, 1)).Find _
      (strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
    Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy
    Range("B" & Rows.Count).End(xlUp).Offset(2, 0) _
      .PasteSpecial xlPasteValues
    i = REnd.Row
  End If
Loop While i < LRow And Not RStart Is Nothing

Range("A:A").Delete
End Sub

Regards,
Howard

 

[nitozinho]

Here is a cleaner version with thanks to Claus of MS Public forum.

Option Explicit

Sub Test2_Claus()
Dim strStart      As String
Dim strEnd        As String
Dim RStart        As Range
Dim REnd          As Range
Dim LRow          As Long
Dim i                As Long

strStart = "XX"
strEnd = "XXX"

i = 1
LRow = Cells(Rows.Count, 1).End(xlUp).Row

Do
  Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
    (strStart, Cells(LRow, 1), xlValues, xlWhole)
  If Not RStart Is Nothing Then
    Set REnd = Range(Cells(i, 1), Cells(LRow, 1)).Find _
      (strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
    Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy
    Range("B" & Rows.Count).End(xlUp).Offset(2, 0) _
      .PasteSpecial xlPasteValues
    i = REnd.Row
  End If
Loop While i < LRow And Not RStart Is Nothing

Range("A:A").Delete
End Sub

Regards,
Howard

Hello, I have made some changes to the code, but now i get an error at the end:
"Run-Time error" 1004:
A table cannot overlap another table.

Can anybody help, please?

Sub Test1()
Dim strStart      As String
Dim strEnd        As String
Dim strTable      As String
Dim RStart        As Range
Dim REnd          As Range
Dim LRow          As Long
Dim i                As Long
Dim n                As Long


    Sheets("Testen").Select


strStart = "START"
strEnd = "END"


i = 1
n = 1
LRow = Cells(Rows.Count, 1).End(xlUp).Row


Do
  Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
    (strStart, Cells(LRow, 1), xlValues, xlWhole)
  If Not RStart Is Nothing Then
    Set REnd = Range(Cells(i, 1), Cells(LRow, 4)).Find _
      (strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
    'Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy
    'Sheets("Testen2").Select
    ActiveSheet.ListObjects.Add(xlSrcRange, Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)), , xlYes).Name = _
        "Table" & n
    ActiveSheet.ListObjects("Table" & n).ShowTableStyleRowStripes = False
    ActiveSheet.ListObjects("Table" & n).ShowHeaders = False
    ActiveSheet.ListObjects("Table" & n).TableStyle = "TableStyleMedium15"
    
    'Range("A" & Rows.Count).End(xlUp).Offset(2, 0) _
      .PasteSpecial xlPasteValues
    i = RStart.Row + 1
    n = n + 1
  End If
Loop While i < LRow And Not RStart Is Nothing




End Sub

 

[nitozinho]

I figured it out... my finaal code:

Sub Test1()Dim strStart      As String
Dim strEnd        As String
Dim strTable      As String
Dim RStart        As Range
Dim REnd          As Range
Dim LRow          As Long
Dim i             As Long
Dim n             As Long


Sheets("Testen").Select


strStart = "START"
strEnd = "END"


i = 1
n = 1
LRow = Cells(Rows.Count, 1).End(xlUp[COLOR=#ff0000]).Offset(4, 0)[/COLOR].Row


Do
  Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
    (strStart, Cells(LRow, 1), xlValues, xlWhole)
  If Not RStart Is Nothing Then
    Set REnd = Range(Cells(i, 1), Cells(LRow, 4)).Find _
      (strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
    If Not REnd Is Nothing Then
 
    ActiveSheet.ListObjects.Add(xlSrcRange, Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)), , xlYes).Name = _
        "Table" & n
    ActiveSheet.ListObjects("Table" & n).ShowTableStyleRowStripes = False
    ActiveSheet.ListObjects("Table" & n).ShowHeaders = False
    ActiveSheet.ListObjects("Table" & n).TableStyle = "TableStyleMedium15"
    ActiveSheet.Range("Table" & n).WrapText = True
    
    
    
    i = RStart.Row + 1
    n = n + 1

  End If
  End If

Loop While i < LRow And Not RStart Is Nothing
   


End Sub