VBA Copy range from and until cell contains specific text

oldb

New Member
Joined
Mar 17, 2021
Messages
12
Office Version
  1. 365
Platform
  1. Windows
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.

mrex.png
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

oldb

New Member
Joined
Mar 17, 2021
Messages
12
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Mar 17, 2021
Messages
12
Office Version
  1. 365
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,383
Messages
5,641,835
Members
417,240
Latest member
pjohnsonexcel

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top