Finding a defined range of cells then Copy & Paste

Hi all,

Looking for a macro to do this but no idea how to write it.

My attached Workbook (in both.xls & .xlsx) has a sheet called "All Data", which has two blocks of data that I am wanting to copy into the sheet named "Race Summaries". I have also included a sheet of "What is should look like" after the macro has stopped running.

NOTE : In reality, I will not be manually highlighting this data - I have done this just to easily show what I am talking about.

1st Block - data I have highlighted YELLOW throughout the "All Data" sheet.
LOOKING TO DO: Copy this data into Columns C to N in "Race Summaries" one after the other (no blank rows).
INITIAL IDEA : Find the first cell from the top with contents "Race", then select the cell just below that and highlight the range 12 columns across and all rows until a blank row is reached.

2nd Block - For every 1st Block in "All Data", there is a related 2nd Block (highlighted RED) located above the 1st Block. It is just a single cell of text data in the format
"[Date] [Track]". The no. of rows between each pair of 1st & 2nd Blocks of data is never the same.
LOOKING TO DO: The [Date] and [Track] parts of the 2nd Block to be seperately copied into columns A and B of "Race Summaries" ONLY in rows that contain the same 2nd Block data that is immediately underneath it on the "All Data" sheet.
INITIAL IDEA: Maybe locate by Finding the first cell from the top with contents "Race Name", then Offset(-2,-1) to select the cell. And use RIGHT(A1,LEN(A1)-FIND(" ",A1)) or LEFT(A1,LEN(A1)-FIND(" ",A1)) to get the [Date] and [Track] text seperated.

And I suppose loop those instructions for EACH PAIR of 1st & 2nd Blocks throughout the "All Data" sheet until there is no longer any 1st or 2nd Blocks that haven't been copied into

I don't know how to write the macro. i suspect its not too difficult, so I hope someone out there can help.

Thanks,
Trent

Hi Pike,

Feel bad that I can't use your suggestion because please read the original request:
"NOTE : In reality, I will not be manually highlighting this data - I have done this just to easily show what I am talking about. "

So, I am looking for a macro that will find the data based on a Text search, then Offset.

To restate:
Please see on the attached on the sheet called "How it should look" - I am only looking copying the cells from "Data" sheet that are coloured Red & Yellow. And for each Yellow section there is a matching Date & Track name contained in the Red highlighted cell roughly 15 rows above it in column A. In all, there are 5 of these data pairings, after which the Copy & paste loop would have to stop.

BUT NOTE: there is no fixed no.of rows for each Yellow range of data AND the no. of rows between the Yellow & Red pairs of data is also Variable - so that is why I would think the sort of Find then Offset code would work in selecting the range.


Thanks again.

Thanks for the code Pike - but there's a few things I'd like to see if you could fix because it didn't present all the data back. See the result with your coding on the attached & compare it to how it differs from the sheet named "What it should look like".

The areas that need fixing are:
(i) The Red coloured data cells that contain "[Date] [Track]" need to be split by using RIGHT(A1,LEN(A1)-FIND(" ",A1)) or LEFT(A1,LEN(A1)-FIND(" ",A1)) and then populate that info in the Date and Track column in "Race Summaries" sheet and it needs to be populated in every row related to the Yellow cell data that it is paired to.

(ii) Do not copy the row headings above the Yellow data because I already have the Header row set up in "Race Summaries" sheet - and I only want one header row. It is just the Yellow data to be copied over.

For anyone else reading this,
NOTE: the colours have been manually added to show you what data I need copy/pasted. Data is not going to be coloured in reality. And there is no set no.of rows for the Yellow highlighted data and the no. of rows between Yellow and Red data is also variable. Pike's code works just apart from the points (i) & (ii) I have made above.

Hoping for a response. So close to the solution I was after.

Thanks
Trent

Thanks for the code Pike but it doesn't populate the Red coloured data correctly and there is an issue with the header rows on top of the Yellow data being included in the copy/paste. See the sheet named "What it should look like".

So close to the solution I was after. I will have learnt alot from your code as it has many applications for what I want to do.

The remaining problems:
(i) The Red coloured data cells that contain "[Date] [Track]" need to be split by using RIGHT(A1,LEN(A1)-FIND(" ",A1)) or LEFT(A1,LEN(A1)-FIND(" ",A1)) and then populate that info in the Date and Track column in "Race Summaries" sheet and it needs to be populated in every row related to the Yellow cell data that it is paired to.

(ii) I already have the Header row set up in "Race Summaries" sheet. It is just the Yellow data to be copied over.

For anyone else reading this,
NOTE: the colours have been manually added to show you what data I need copy/pasted. Data is not going to be coloured in reality. And there is no set no.of rows for the Yellow highlighted data and the no. of rows between Yellow and Red data is also variable. Pike's code works just apart from the points (i) & (ii) I have made above.

Thanks
Trent

Simple un-modified recorded macro (in other words it is still sloppy and inefficient).

However if it does what you are trying to do in the example provided then you should be able to clean it up to work for you. If this will work and you don't know how to clean it up I can do that.

Please Login or Register  to view this content.

Code:
Sub tester()
Dim xCell
With Sheets("All Data")
For Each xCell In .Range("a1", .Cells(Rows.Count, 1).End(xlUp))
If xCell.Value Like "*/*/*" Then
xCell.Copy Worksheets("Race Summaries").Cells(Rows.Count, "c").End(xlUp).Offset(1, -2)
ElseIf xCell.Value Like "RACE" Then
xCell.CurrentRegion.Copy Worksheets("Race Summaries").Cells(Rows.Count, "c").End(xlUp).Offset(1, 0)
End If
Next
End With
End Sub

Thanks for the code Pike but it doesn't populate the Red coloured data correctly and there is an issue with the header rows on top of the Yellow data being included in the copy/paste. See the sheet named "What it should look like".
The problems (in summary):
(i) The Red coloured data cells that contain "[Date] [Track]" need to be split by using RIGHT(A1,LEN(A1)-FIND(" ",A1)) or LEFT(A1,LEN(A1)-FIND(" ",A1)) and then populate that info in the Date and Track column in "Race Summaries" sheet and it needs to be populated in every row related to the Yellow cell data that it is paired to.
(ii) I already have the Header row set up in "Race Summaries" sheet. It is just the Yellow data to be copied over.

For anyone else reading this,
NOTE: the colours have been manually added to show you what data I need copy/pasted. Data is not going to be coloured in reality. And there is no set no.of rows for the Yellow highlighted data and the no. of rows between Yellow and Red data is also variable. Pike's code works just apart from the points (i) & (ii) I have made above.

Thanks
Trent

Need help to fix two things about this code provided by Pike. File is attached which shows the output of this code & there is a sheet call "What this should look like".

NOTE: the colours have been manually added to show you what data I need copy/pasted. Data is not going to be coloured in reality. And there is no fixed no.of rows for the Yellow highlighted data and the no.of rows between Yellow and Red data is also variable.

The problems (in summary):
(i) The Red coloured data cells that contain "[Date] [Track]" need to be split by using RIGHT(A1,LEN(A1)-FIND(" ",A1)) or LEFT(A1,LEN(A1)-FIND(" ",A1)) and then populate that info in the Date and Track column in "Race Summaries" sheet. This info should also be populating every row which contains Yellow data that it is paired to.
(ii) I already have the Header row set up in "Race Summaries" sheet. It is just the Yellow data to be copied over.

Code:
Sub tester()
Dim xCell
With Sheets("All Data")
For Each xCell In .Range("a1", .Cells(Rows.Count, 1).End(xlUp))
If xCell.Value Like "*/*/*" Then
xCell.Copy Worksheets("Race Summaries").Cells(Rows.Count, "c").End(xlUp).Offset(1, -2)
ElseIf xCell.Value Like "RACE" Then
xCell.CurrentRegion.Copy Worksheets("Race Summaries").Cells(Rows.Count, "c").End(xlUp).Offset(1, 0)
End If
Next
End With
End Sub




Thanks
Trent