VBA Copy range from and until cell contains specific text

[oldb]

Hi guys,

I'm trying to find a way to copy a range from and until a cell contains a specific text.
So let's say I have two worksheets that look (sort of) like the picture. They're named Jan and Feb, and I need to to separate the data into one sheet for each color (so one for green, one for blue and one for yellow).
Since the range differs slightly in these two sheets I need to a way to copy the rows that are in-between the red colored cells (which contain the specific text: JPY, MXN & USD). Also once the data is copied it would be nice if it was arranged alphabetically. Thanks a lot.

 

[oldb]

So I worked something out, but I still have a problem... the first two parts work fine, but the last part is a bit tricky... I have to set the range from USD to a blank cell, but there are blank cells in rows 1&2 so I think that's why it's not working properly... anyway here's my code... Help would be appreciated... Thanks

Dim i As Long
On Error Resume Next
For i = 1 To Sheets.Count

Sheets(i).Activate
Findstart = WorksheetFunction.Match("JPY", [a:a], False)
findend = WorksheetFunction.Match("MXN", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("JPY").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Sheets(i).Activate
Findstart = WorksheetFunction.Match("MXN", [a:a], False)
findend = WorksheetFunction.Match("USD", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("MXN").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

'here's where it's stops working because I have to set the findend to a blank cell, but there's a blank cell in row 1 too
Sheets(i).Activate
Findstart = WorksheetFunction.Match("USD", [a:a], False)
findend = WorksheetFunction.Match("", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("USD").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Application.CutCopyMode = False
Next i
On Error GoTo 0

End Sub

 

[oldb]

So I worked something out, but I still have a problem... the first two parts work fine, but the last part is a bit tricky... I have to set the range from USD to a blank cell, but there are blank cells in rows 1&2 so I think that's why it's not working properly... anyway here's my code... Help would be appreciated... Thanks

Dim i As Long
On Error Resume Next
For i = 1 To Sheets.Count

Sheets(i).Activate
Findstart = WorksheetFunction.Match("JPY", [a:a], False)
findend = WorksheetFunction.Match("MXN", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("JPY").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Sheets(i).Activate
Findstart = WorksheetFunction.Match("MXN", [a:a], False)
findend = WorksheetFunction.Match("USD", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("MXN").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

'here's where it's stops working because I have to set the findend to a blank cell, but there's a blank cell in row 1 too
Sheets(i).Activate
Findstart = WorksheetFunction.Match("USD", [a:a], False)
findend = WorksheetFunction.Match("", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("USD").Activate
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Application.CutCopyMode = False
Next i
On Error GoTo 0

End Sub

Nevermind, figured it out... but now I have another problem... in the first bit (the JPY to MXN one) it only starts copying from sheet nr8 for some reason, but if I run it twice it starts at the right sheet (nr5), anyone have an idea why??

here's the new code

Dim i As Long
On Error Resume Next
For i = 5 To Sheets.Count

Sheets(i).Activate
Findstart = WorksheetFunction.Match("JPY", [a:a], False)
findend = WorksheetFunction.Match("MXN", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("JPY").Activate
Range("E1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Sheets(i).Activate
Findstart = WorksheetFunction.Match("MXN", [a:a], False)
findend = WorksheetFunction.Match("USD", [a:a], False)
Range("a" & Findstart + 1, "a" & findend - 1).Copy

Sheets("MXN").Activate
Range("E1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Sheets(i).Activate
Findstart = WorksheetFunction.Match("USD", [a:a], False)
findend = Cells(Rows.Count, 1).End(xlUp).Row
Range("a" & Findstart + 1, "a" & findend).Copy

Sheets("USD").Activate
Range("E1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste


Application.CutCopyMode = False
Next i


On Error GoTo 0