PDA

View Full Version : [SOLVED] VBA to copy row if cells contain value



MattehWoo
07-19-2016, 07:06 AM
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

offthelip
07-19-2016, 07:30 AM
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:

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

MattehWoo
07-20-2016, 12:46 AM
You my friend, are a legend. Thankyou.

MattehWoo
07-25-2016, 07:19 AM
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?

jolivanes
07-25-2016, 10:46 PM
Try this.

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.

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

MattehWoo
07-27-2016, 01:56 AM
Try this.

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?

jolivanes
07-27-2016, 08:37 AM
Change this line from

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

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

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

MattehWoo
07-28-2016, 12:19 AM
Amazing. Cheers :)

jolivanes
03-19-2021, 08:20 PM
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.

SamT
03-20-2021, 12:44 PM
Last post by edson.paula (http://www.vbaexpress.com/forum/member.php?81431-edson-paula) moved to http://www.vbaexpress.com/forum/showthread.php?68569-Copy-Rows-with-Certain-Values