Copy info between 2 specific words

[Wolfwalker721]

Hi,

I have been trying to use a macro to find a word in a column, then find the
next instance of that word in the same colum, Then copy the information
between+4 colums to another sheet, in the first blank column, in the same
workbook.

I hope this makes sence. I can generaly grasp basic macro commands but I am
in over my head on this one. Any help would be appriciated.

THANKS in advance

 

[Joel]

Change the sheet names and the start and end columns as required.

Sub GetData()

Set Sourcesht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

StartCol = "C"
EndCol = "G"
SearchWord = "Joel"


RowCount = 1
StartRow = 0
With Sourcesht
LastRow1 = .Range(StartCol & Rows.Count).End(xlUp).Row
Found = False
For RowCount = 1 To LastRow1
Select Case Found

Case False:
If .Range(StartCol & RowCount) = SearchWord Then
Found = True
StartRow = RowCount
End If
Case True
If .Range(StartCol & RowCount) = SearchWord Then
Set CopyRange = _
.Range(StartCol & StartRow & ":" & _
EndCol & RowCount)

With DestSht
LastRow2 = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow2 + 1
CopyRange.Copy _
Destination:=.Range("A" & NewRow)
End With
Found = False
End If
End Select
Next RowCount
End With
End Sub

 

[Wolfwalker721]

This works great! Only I am trying to copy the info in the first blank column
instead of the first blank row. =)

Thanks so much for yout time!

 

[Joel]

This is similar code for columns. I'm not sure if you are looking a one row
or moving down the worksheet and looking at all rows. You need to use CELLS
instead of RANGE when using columns.

 

[Wolfwalker721]

Thanks this is a big help, to clarify

I am trying to search the entire A column where the word "Done" appears many
times, then copy Column A-D between each instance of the word "Done" and
paste it to another sheet in the first empty colum.

 

[Joel]

The 1st macro was closer to what you wanted than the 2nd. If ther are more
than 256/4 setctions that need to be copied then you are goig to go past
column 256 and an error will occur. the macro could be easily mdoifed when
256 column (IV) is reached the code will wrap back to column A.

Change sheet names as required.

Sub GetData()

Set Sourcesht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

StartCol = "A"
EndCol = "D"
SearchWord = "Done"


RowCount = 1
StartRow = 0
With Sourcesht
LastRow = .Range(StartCol & Rows.Count).End(xlUp).Row
Found = False
For RowCount = 1 To LastRow
Select Case Found
Case False:
If .Range(StartCol & RowCount) = SearchWord Then
Found = True
StartRow = RowCount
End If
Case True
If .Range(StartCol & RowCount) = SearchWord Then
Set CopyRange = _
.Range(StartCol & StartRow & ":" & _
EndCol & RowCount)

With DestSht
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Row
NewCol = LastCol + 1
CopyRange.Copy _
Destination:=.Cells(1, NewCol)
End With
Found = False
End If
End Select
Next RowCount
End With
End Sub

 

[Wolfwalker721]

This is GREAT! THANKS

The 1st macro was closer to what you wanted than the 2nd. If ther are more
than 256/4 setctions that need to be copied then you are goig to go past
column 256 and an error will occur. the macro could be easily mdoifed when
256 column (IV) is reached the code will wrap back to column A.

Change sheet names as required.

Sub GetData()

Set Sourcesht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

StartCol = "A"
EndCol = "D"
SearchWord = "Done"


RowCount = 1
StartRow = 0
With Sourcesht
LastRow = .Range(StartCol & Rows.Count).End(xlUp).Row
Found = False
For RowCount = 1 To LastRow
Select Case Found
Case False:
If .Range(StartCol & RowCount) = SearchWord Then
Found = True
StartRow = RowCount
End If
Case True
If .Range(StartCol & RowCount) = SearchWord Then
Set CopyRange = _
.Range(StartCol & StartRow & ":" & _
EndCol & RowCount)

With DestSht
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Row
NewCol = LastCol + 1
CopyRange.Copy _
Destination:=.Cells(1, NewCol)
End With
Found = False
End If
End Select
Next RowCount
End With
End Sub