Seach all WS

[Jerry Foley]

Hello,
given
Sub mastertest1()
Dim rSource As Range
Dim rDest As Range
Dim rCell As Range

On Error Resume Next
With ThisWorkbook.Sheets("New IP Office")
Set rSource = .Range(.Cells(1, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
Set rDest = .Parent.Sheets("Sheet2").Cells( _
.Rows.Count, 1).End(xlUp).Offset(19, 0)
End With
On Error GoTo 0
If (Not rSource Is Nothing) And (Not rDest Is Nothing) Then
For Each rCell In rSource
With rCell
If Not IsEmpty(.Value) Then
If IsNumeric(.Value) Then
.EntireRow.Copy Destination:=rDest
Set rDest = rDest.Offset(1, 0)
End If
End If
End With
Next rCell
End If
End Sub
How do I make this macro search ws named New Avaya also?
Thanks

 

[Dave Peterson]

Option Explicit
Sub mastertest1()
Dim rSource As Range
Dim rDest As Range
Dim rCell As Range
Dim wks As Worksheet

For Each wks In Worksheets(Array("New IP Office", "New Avaya"))

On Error Resume Next
Set rSource = Nothing
Set rDest = Nothing
With wks
Set rSource = .Range(.Cells(1, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
Set rDest = .Parent.Sheets("Sheet2").Cells( _
.Rows.Count, 1).End(xlUp).Offset(19, 0)
End With
On Error Resume Next

If (Not rSource Is Nothing) And (Not rDest Is Nothing) Then
For Each rCell In rSource
With rCell
If Not IsEmpty(.Value) Then
If IsNumeric(.Value) Then
.EntireRow.Copy Destination:=rDest
Set rDest = rDest.Offset(1, 0)
End If
End If
End With
Next rCell
End If
Next wks
End Sub

 

[Jerry Foley]

How can I modify this macro to write the data on sheet2 starting at line 17
and continue down. It now writes the data at line 19 but seems to be
truncating the data upwards.

 

[Dave Peterson]

I'm confused.

The line that you use to determine the destination cell is:

Set rDest = .Parent.Sheets("Sheet2").Cells( _
.Rows.Count, 1).End(xlUp).Offset(19, 0)

It looks at the last used cell of column A, then goes down 19 rows.

If you really want to start in A17 no matter what's there, you could use:

Set rDest = .Parent.Sheets("Sheet2").range("a17")


====
Maybe you want to keep going down the range no matter what worksheet you're
on???

Something like:

Option Explicit
Sub mastertest1()
Dim rSource As Range
Dim rDest As Range
Dim rCell As Range
Dim wks As Worksheet

With Sheets("sheet2")
Set rDest = .Cells(.Rows.Count, 1).End(xlUp).Offset(19, 0)
'or
'Set rDest = .range("a17")
End With

For Each wks In Worksheets(Array("New IP Office", "New Avaya"))
With wks
Set rSource = .Range(.Cells(1, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
End With

If (Not rSource Is Nothing) And (Not rDest Is Nothing) Then
For Each rCell In rSource
With rCell
If Not IsEmpty(.Value) Then
If IsNumeric(.Value) Then
.EntireRow.Copy Destination:=rDest
Set rDest = rDest.Offset(1, 0)
End If
End If
End With
Next rCell
End If
Next wks
End Sub

 

[Jerry Foley]

Yes...Is there a way to make the data written to sheet2 is inserted so the
total cells at the bottom of the col stays in tact?

 

[Dave Peterson]

I don't know. It depends on how many cells are available for pasting and where
your data starts.

Maybe you could just insert a new row and paste into that?

Option Explicit
Sub mastertest1()
Dim rSource As Range
Dim rCell As Range
Dim wks As Worksheet

For Each wks In Worksheets(Array("New IP Office", "New Avaya"))

Set rSource = Nothing
With wks
Set rSource = .Range(.Cells(1, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
End With

If (Not rSource Is Nothing) Then
For Each rCell In rSource
With rCell
If Not IsEmpty(.Value) Then
If IsNumeric(.Value) Then
Worksheets("sheet2").Rows(17).Insert
.EntireRow.Copy _
Destination:=Worksheets("sheet2").Range("a17")
End If
End If
End With
Next rCell
End If
Next wks
End Sub

 

[Jerry Foley]

Great help Dave...I have hopefully one last question...when i run this macro
it is now reading the rows fine but when it inserts it to sheet2, it is
inserting above the last line so that all of the data is bottom to top
instead of top to bottom. any fix ideas?

 

[Dave Peterson]

I'm still not quite sure what's happening, but maybe just going from the bottom
to the top would be sufficient:

Option Explicit
Sub mastertest1()
Dim rSource As Range
Dim rCell As Range
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim wks As Worksheet

For Each wks In Worksheets(Array("New IP Office", "New Avaya"))
With wks
FirstRow = 4
LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
End With

For iRow = LastRow To FirstRow Step -1
Set rCell = wks.Cells(iRow, 4)
With rCell
If Not IsEmpty(.Value) Then
If IsNumeric(.Value) Then
Worksheets("sheet2").Rows(17).Insert
.EntireRow.Copy _
Destination:=Worksheets("sheet2").Range("a17")
End If
End If
End With
End If
Next wks
End Sub

Great help Dave...I have hopefully one last question...when i run this macro
it is now reading the rows fine but when it inserts it to sheet2, it is
inserting above the last line so that all of the data is bottom to top
instead of top to bottom. any fix ideas?

 

[Jerry Foley]

Hey Dave,
The last macro you gave me is getting compile erros at the end. The issue
prior to this is the data being copied from the wks are being copied in
reverse order, i.e. row 9 gets copied to sheet 2 ahead of row 8 etc...

 

[Dave Peterson]

That last "end if" should have been "next irow"

sorry.

Hey Dave,
The last macro you gave me is getting compile erros at the end. The issue
prior to this is the data being copied from the wks are being copied in
reverse order, i.e. row 9 gets copied to sheet 2 ahead of row 8 etc...