copy all rows between two values where the first value is variable

[Grazier]

Hello!

I have the following problem with a code:

I have 2 sheets, named "Sheet1" and "Summary"

In the "Sheet1", I have data like:

A
1 FCR-E00001
2 something
3 something
4 something
5 FCR-F38346
6 something
7 something
8 FCR-Y02934
etc

The letters and numbers after the "FCR-" are not constant, but the first part stays the same.

What I need to do is, look for example "FCR-F38346" and the macro would copy that row and all the rows related to it (in this case A5, A6 and A7). I have made a code as far as finding and copying when I give the code both entries, like FCR-F38346 and FCR-Y02934 manually.

But I need to implement an InputBox to set the first value to be searched, and it needs to loop until it finds the NEXT "FCR-" in the column.

For example, if I search for FCR-E00001, it loops until it finds FCR-F38346, and copies all the rows between to the sheet "Summary".

I didn't manage to implement the InputBox, and I couldn't make the loop to stop at the next "FCR-" line.

Here is what I have so far:

Sub Search()
   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Sheet1").Range("a1:a" & lastrow)
   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "FCR-E00001" Then 'Needs to be changed to variant
          startrow = rownum
       End If
       rownum = rownum + 1
   If (rownum > lastrow) Then Exit For
   Loop Until .Cells(rownum, 1).Value <> "FCR" 'Needs to look for the next "FCR" in line and stop
   endrow = rownum - 1
   rownum = rownum + 1
   Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
   Sheets("Summary").Select
   Range("A1").Select
   ActiveSheet.Paste
   Next rownum
   End With
   End Sub

Thank you for your assistance!

-Grazier

 

[mumps]

Try:

Sub Test()
    Dim FindString As String
    Dim fRow As Range
    Dim lRow As Range
    Dim bottomA As Integer
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    FindString = InputBox("Enter search value.")
        With Sheets("Sheet1").Range("A:A")
            Set fRow = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        End With
        
        With Sheets("Sheet1").Range(Cells(fRow.Row + 1, 1), Cells(bottomA, 1))
            Set lRow = .Find(What:="FCR", _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        End With
        
    Sheets("Sheet1").Rows(fRow.Row & ":" & lRow.Row - 1).Copy Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End Sub

 

[JLGWhiz]

If I understand it right, you want to find a specific FRC number though use of an inputbox. Then you want to copy that row and all rows underneath that entry up to the next FRC entry. If that is correct The this should work for you.

Code:
Sub FRC()
Dim sh As Worksheet, lr As Long, rng As Range, fDat As Range
Dim tVal As String, fAdr As String, lAdr As String, x As Long
Set sh = Sheets("Sheet1")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)
src = InputBox("Enter string to search.", "SEARCH STRING")
src = UCase(src)
Set fDat = rng.Find(src, LookIn:=xlValues)
If Not fDat Is Nothing Then
fAdr = fDat.Address
X = 1
Do
tVal = fDat.Offset(X, 0)
If tVal = "" Then
MsgBox "Blank cell at " & fDat.Offset(X, 0).Address
Exit Sub
End If
X = X + 1
Loop Until Left(UCase(tVal), 3) = "FRC"
lAdr = Range(fAdr).Offset(X - 2, 0).Address
End If
sh.Range(fAdr, lAdr).Copy Sheets("Summary").Cells(Rows.Count, 1).End(xlUp)(2)
End Sub
Code:

 

[Grazier]

Hey guys!

Again, I tried the codes, and they both did what I wanted!

Also, both of them returned an error if the search value was blank, or if the value couldn't be found. But that part I figured out myself

Thanks alot to both of you! You're awesome

Here attached is the final code which I edited a bit so that it wouldn't return an error on above mentioned reasons:

Sub FCR()
Dim sh As Worksheet
Dim lr As Long
Dim rng As Range
Dim fDat As Range
Dim tVal As String
Dim fAdr As String
Dim lAdr As String
Dim x As Long
Set sh = Sheets("Sheet1")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)
src = InputBox("Enter a search value.", "SEARCH FOR FCR")
src = UCase(src)
If src = "" Then End
On Error Resume Next
Set fDat = rng.Find(src, LookIn:=xlValues)
If Not fDat Is Nothing Then
fAdr = fDat.Address
x = 1
Do
tVal = fDat.Offset(x, 0)
If tVal = "" Then
MsgBox "Blank cell at " & fDat.Offset(x, 0).Address
Exit Sub
End If
x = x + 1
Loop Until Left(UCase(tVal), 3) = "FCR"
lAdr = Range(fAdr).Offset(x - 2, 0).Address
End If
sh.Range(fAdr, lAdr).Copy Sheets("Summary").Cells(Rows.Count, 1).End(xlUp)(2)
End Sub

Thanks again!

-Grazier

 

[Grazier]

Hey,

I just now noticed that the code above does not copy ROWS to the summary sheet, but only cells.

I managed to fix this, and wanted to paste the code. So here it is:

Sub FCR()
Dim sh As Worksheet
Dim lr As Long
Dim rng As Range
Dim fDat As Range
Dim tVal As String
Dim fAdr As String
Dim lAdr As String
Dim x As Long
Sheets("Sheet1").Activate
Set sh = Sheets("Sheet1")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("C2:C" & lr)
src = InputBox("Enter a search value.", "SEARCH FOR FCR")
src = UCase(src)
If src = "" Then End
On Error Resume Next
Set fDat = rng.Find(src, LookIn:=xlValues)
If Not fDat Is Nothing Then
fAdr = fDat.Address
x = 1
Do
tVal = fDat.Offset(x, 0)
If tVal = "" Then
MsgBox "Blank cell at " & fDat.Offset(x, 0).Address
Exit Sub
End If
x = x + 1
Loop Until Left(UCase(tVal), 3) = "FCR"
lAdr = Range(fAdr).Offset(x - 2, 0).Address
End If
sh.Range(fAdr, lAdr).Select
Selection.EntireRow.Copy Sheets("Summary").Cells(Rows.Count, 1).End(xlUp)(2)
Sheets("Summary").Activate
End Sub

-Grazier

 

[JLGWhiz]

Hey,

I just now noticed that the code above does not copy ROWS to the summary sheet, but only cells.

I managed to fix this, and wanted to paste the code. So here it is:

Sub FCR()
Dim sh As Worksheet
Dim lr As Long
Dim rng As Range
Dim fDat As Range
Dim tVal As String
Dim fAdr As String
Dim lAdr As String
Dim x As Long
Sheets("Sheet1").Activate
Set sh = Sheets("Sheet1")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("C2:C" & lr)
src = InputBox("Enter a search value.", "SEARCH FOR FCR")
src = UCase(src)
If src = "" Then End
On Error Resume Next
Set fDat = rng.Find(src, LookIn:=xlValues)
If Not fDat Is Nothing Then
fAdr = fDat.Address
x = 1
Do
tVal = fDat.Offset(x, 0)
If tVal = "" Then
MsgBox "Blank cell at " & fDat.Offset(x, 0).Address
Exit Sub
End If
x = x + 1
Loop Until Left(UCase(tVal), 3) = "FCR"
lAdr = Range(fAdr).Offset(x - 2, 0).Address
End If
sh.Range(fAdr, lAdr).Select
Selection.EntireRow.Copy Sheets("Summary").Cells(Rows.Count, 1).End(xlUp)(2)
Sheets("Summary").Activate
End Sub

-Grazier

Yep, good catch. Had a senior moment there.

regards, JLG

 

[raulmiho]

Hi your code works well, but I want to change it in order to loop and extract all the rows between two different words (For Example, HELLO and BYE) that repeat in a column. For intance.

1 HELLO
2 something
3 something
4 something
5 BYE
6 HELLO
7 something
8 BYE
1 HELLO
2 something
3 something
4 BYE
etc

and I would like to extract all the "somethings" in a new sheet.

By now your code works only for the first "somethings" and I couldnt adapt it to loop for all the somethings down the sheet.

Thanks in advance for orientation!!

 

[raulmiho]

Try:

Sub Test()
    Dim FindString As String
    Dim fRow As Range
    Dim lRow As Range
    Dim bottomA As Integer
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    FindString = InputBox("Enter search value.")
        With Sheets("Sheet1").Range("A:A")
            Set fRow = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        End With
        
        With Sheets("Sheet1").Range(Cells(fRow.Row + 1, 1), Cells(bottomA, 1))
            Set lRow = .Find(What:="FCR", _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        End With
        
    Sheets("Sheet1").Rows(fRow.Row & ":" & lRow.Row - 1).Copy Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End Sub

Hi your code works well, but I want to change it in order to loop and extract all the rows between two different words (For Example, HELLO and BYE) that repeat in a column. For intance.

1 HELLO
2 something
3 something
4 something
5 BYE
6 HELLO
7 something
8 BYE
1 HELLO
2 something
3 something
4 BYE
etc

and I would like to extract all the "somethings" in a new sheet.

By now your code works only for the first "somethings" and I couldnt adapt it to loop for all the somethings down the sheet.

Thanks in advance for orientation!!

 

[mumps]

@raulmiho: Welcome to the forum. You should be aware that it is against Forum rules to ask your question in another person's thread. Please start a new thread to post your issue. If you found this thread useful, you can include a link to it in your new thread.