copying multiple row to a new sheet

[Guest]

I got my code working where it copies a row and moves it over to the other sheet, but if I have multiple rows to move over it only moves the first row that is true, but not the others. How can I get it to move every row that is true over to a new sheet. Here's my code

Dim rng As Range, cell As Range, rng1 As Rang
Set rng = Range(Cells(2, "B"), Cells(Rows.Count, "B").End(xlUp)
Set rng1 = Nothin
For Each cell In rn
If cell.Value = "True" The
If rng1 Is Nothing The
Set rng1 = cel
Els
Set rng1 = Union(rng1, cell
End I
End I
Nex
If Not rng1 Is Nothing The
rng1.Range("B1:H1").Copy Destination:=Worksheets("Sheet2").Range("B2"
End I

 

[Frank Kabel]

Hi
try changing the line
rng1.Range("B1:H1").Copy Destination:=Worksheets("Sheet2").Range("B2")

to
rng1.Copy Destination:=Worksheets("Sheet2").Range("B2")

 

[Ron de Bruin]

Try this

This example you can use for more words also
See the Array

Sub Union_Examples()
Dim myArr As Variant
Dim FirstAddress As String
Dim Rng As Range
Dim Totrng As Range
Dim I As Long

Application.ScreenUpdating = False
myArr = Array("True")

For I = LBound(myArr) To UBound(myArr)

Set Rng = Range("B:B").Find(What:=myArr(I), After:=Range("B" _
& Rows.Count), LookAt:=xlWhole)
'If you want to search in a part of the rng.value then use xlPart

If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
If Totrng Is Nothing Then
Set Totrng = Rng
Else
Set Totrng = Application.Union(Totrng, Rng)
End If
Set Rng = Range("B:B").FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
If Not Totrng Is Nothing Then
Totrng.EntireRow.Copy Sheets(2).Rows(2)
'Copy to another sheet
End If
Application.ScreenUpdating = True
End Sub



--
Regards Ron de Bruin
(Win XP Pro SP-1 XL2000-2003)

I got my code working where it copies a row and moves it over to the other sheet, but if I have multiple rows to move over it

only moves the first row that is true, but not the others. How can I get it to move every row that is true over to a new sheet.
Here's my code:

 

[Guest]

why dont u try using this approach:
Use your For loop to find all "true" values,
then use X = Cell.row to identify the Row,
then use Rows(x). Copy destination:=Worksheets("Sheet2").rows(x

----- still stuck wrote: ----

I got my code working where it copies a row and moves it over to the other sheet, but if I have multiple rows to move over it only moves the first row that is true, but not the others. How can I get it to move every row that is true over to a new sheet. Here's my code

Dim rng As Range, cell As Range, rng1 As Rang
Set rng = Range(Cells(2, "B"), Cells(Rows.Count, "B").End(xlUp)
Set rng1 = Nothin
For Each cell In rn
If cell.Value = "True" The
If rng1 Is Nothing The
Set rng1 = cel
Els
Set rng1 = Union(rng1, cell
End I
End I
Nex
If Not rng1 Is Nothing The
rng1.Range("B1:H1").Copy Destination:=Worksheets("Sheet2").Range("B2"
End I

 

[Guest]

I tried using the code with this line
rng1.Copy Destination:=Worksheets("Sheet2").Range("B2"

but it still doesn't do what I need it to do. I'm really stuck on this. For the rows that are true, I need to move part of that row over to another sheet, and I've gotten it to the point where it moves the first row over, but then every other true in that column will not move over. If anybody has any other suggestions it would be greatly appreciated.

 

[Frank Kabel]

Hi
if I understood you you would like to copy columns B:H for each row in
whcih column B 0 "True". If this is correct try

Sub foo()
Dim rng As Range, cell As Range, rng1 As Range
Set rng = Range(Cells(2, "B"), Cells(Rows.Count, "B").End(xlUp))
Set rng1 = Nothing
For Each cell In rng
If cell.Value = "True" Then
If rng1 Is Nothing Then
Set rng1 = Range(cell, Cells(cell.row, "H"))
Else
Set rng1 = Union(rng1, Range(cell, Cells(cell.row, "H")))
End If
End If
Next
If Not rng1 Is Nothing Then
rng1.Copy Destination:=Worksheets("Sheet2").Range("B2")

End If
End Sub

 

[Guest]

It works! Thank you so much for your help! How did you learn how to do all that so fast, I'm impressed.

 

[Frank Kabel]

Hi
thanks for the feedback. Glad it works (as it was just a good guess)