VBA to copy row if cells contain value

Hi guys and girls...

I have the following set of results in excel:

R01	4940	19-Jan-15
R002	5184	23-Feb-15
R001	5362	27-Mar-15
R002	5429	01-May-15
R01	5434	07-Aug-15
R2	5434	09-Nov-15
R001	5434	09-Feb-16
R001	5434	09-May-16

I need a VBA code to look for the cells that have a "1" in and copy them to one sheet, and copy the cells with a "2" in to another....

I've tried using:

For Each Cell In Sheets("3").Range("A:A")
If Cell.Value = "R001" Then
MatchRow = Cell.Row
Rows(MatchRow & ":" & MatchRow).Select
Selection.Copy
Sheets("4").Select
ActiveSheet.Rows(MatchRow + 1).Select
ActiveSheet.Paste
Sheets("4").Select
End If
Next

But this just finds the first row of R0001 and keeps copying the first row rather than moving on and copying the second... so i end up with :

R001

5362

27-Mar-15

3 times rather than all 3 R0001.... It also doesn't help grab the other "1"'s

Any help would be massively appreciated...

Cheers

I have made the assumption that you want any string with a 1 in it in columns A to c and any string with a 2 in it in columns E to G of sheet 4.
I have defined a variable "endrow" which you can set to what ever your data needs. Or you could detect it automatically.

Try this:

[VBA]Sub moved()
Dim endrow As Integer


endrow = 8
With Worksheets("Sheet3")
inarr = .Range("a1:c" & endrow)
End With
With Worksheets("Sheet4")
outarr = .Range("a1:g" & endrow)
End With
outcnt1 = 1
outcnt2 = 1
For i = 1 To endrow
find1 = InStr(inarr(i, 1), "1")
If find1 > 0 Then
For j = 1 To 3
outarr(outcnt1, j) = inarr(i, j)
Next j
outcnt1 = outcnt1 + 1
End If

find2 = InStr(inarr(i, 1), "2")
If find2 > 0 Then
For j = 1 To 3
outarr(outcnt2, j + 4) = inarr(i, j)
Next j
outcnt2 = outcnt2 + 1
End If
Next i
Worksheets("sheet4").Activate
With Worksheets("Sheet4")
.Range("a1:g" & endrow) = outarr
End With
End Sub


[/VBA]

You my friend, are a legend. Thankyou.

I've just come accross an issue... If new data does not have an 'R2' it errors. Is there a simple way to make it ignore this if there are no other numbers?

Try this.

Code:

---

Sub Transfer_Ones_And_Twos()
    Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Right(c.Value, 1) = 1 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next c
End Sub

---

If you have a large range, this might be slightly faster. Change Sheet references as required.

Code:

---

Sub With_AutoFilter()
    Dim lr As Long
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    Columns("A:A").Insert Shift:=xlToRight
    Range("A1").Value = "Temp"
    Range("A2:A" & lr).Formula = "=RIGHT(RC[1], 1)"
    With Columns("A")
        .AutoFilter 1, 1
        .Range("B2:D" & lr).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter 1, 2
        .Range("B2:D" & lr).Copy Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
    Columns("A").Delete
    Application.ScreenUpdating = True
End Sub

---

Quote:

---

Originally Posted by jolivanes

Try this.

Code:

---

Sub Transfer_Ones_And_Twos()
    Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Right(c.Value, 1) = 1 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next c
End Sub

---

---

I like this. How would i go about making the 1s go to columns ABC and the 2s to FGH?

Change this line from

Code:

---

If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)

---

to

Code:

---

If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 6).End(xlUp).Offset(1)

---

to reflect the Sheet (here Sheet2) and Column (Column F = 6)
so the code becomes

Code:

---

Sub Transfer_Ones_And_Twos_One_Sheet()
    Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Right(c.Value, 1) = 1 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)    '<---- 1 = Column A
        If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 6).End(xlUp).Offset(1)    '<---- 6 = Column F
    Next c
End Sub

---

Amazing. Cheers :)

This thread is 5 years old so it would be better to start a new one. Refer to this one if you think it helps.
Explain in detail what you want ("and so on" only makes sense if you know where it ends).
The best thing to do is attach a workbook with a before and after with and explanation on how you arrived at the after part.

Last post by edson.paula moved to http://www.vbaexpress.com/forum/show...Certain-Values