Help Modifying Macro - Merge multiple sheets based on a condition

[ScottMSP]

Hello,

I have the following code below. I have a total of 7 seperate worksheets
within a workbook that I want this macro to run on. Essentially I want to be
able to copy any row that has a number in column B. This macro works great
for one worksheet, but I want to be able to take all 7 sheets and combine
into one sheet.

Thanks in advance.

Sub CopyRowsWithNumbersInB()
Dim X As Long
Dim LastRow As Long
Dim Source As Worksheet
Dim Destination As Worksheet
Dim RowsWithNumbers As Range
Set Source = Worksheets("Clinical Nursing")
Set Destination = Worksheets("Sheet2")
With Source
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For X = 2 To LastRow
If IsNumeric(.Cells(X, "B").Value) And .Cells(X, "B").Value <> "" Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(X, "B")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X, "B"))
End If
End If
Next
If Not RowsWithNumbers Is Nothing Then
RowsWithNumbers.EntireRow.Copy Destination.Range("A1")
End If
End With
End Sub

 

[Joel]

Sub CopyRowsWithNumbersInB()
Dim X As Long
Dim LastRow As Long
Dim Source As Worksheet
Dim Destination As Worksheet
Dim RowsWithNumbers As Range
Set Source = Worksheets("Clinical Nursing")
Set Destination = Worksheets("Sheet2")
For Each sht In Sheets
If UCase(sht.Name) <> ("SHEET2") Then
With sht
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For X = 2 To LastRow
If IsNumeric(.Cells(X, "B").Value) And .Cells(X, "B").Value <>
"" Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(X, "B")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X,
"B"))
End If
End If
Next X
If Not RowsWithNumbers Is Nothing Then
LastRow = Destination.Cells(Rows.Count, "B").End(xlUp).Row
RowsWithNumbers.EntireRow.Copy Destination.Range("A" & (LastRow
+ 1))
End If
End With
End If
Next sht
End Sub

 

[ScottMSP]

Joel,

The macro failed. It looks like it failed on this line:

RowsWithNumbers = Union(RowsWithNumbers, .Cells(X, "B"))

Thoughts?

Thanks in advance.

 

[Joel]

Union won't work across multiple worksheets. We need to set the Union to
nothing as we change worksheets.

Sub CopyRowsWithNumbersInB()
Dim X As Long
Dim LastRow As Long
Dim Source As Worksheet
Dim Destination As Worksheet
Dim RowsWithNumbers As Range
Set Source = Worksheets("Clinical Nursing")
Set Destination = Worksheets("Sheet2")
For Each sht In Sheets
If UCase(sht.Name) <> ("SHEET2") Then
Set RowsWithNumbers = Nothing
With sht
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For X = 2 To LastRow
If IsNumeric(.Cells(X, "B").Value) And .Cells(X, "B").Value <>
"" Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(X, "B")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X,
"B"))
End If
End If
Next X
If Not RowsWithNumbers Is Nothing Then
LastRow = Destination.Cells(Rows.Count, "B").End(xlUp).Row
RowsWithNumbers.EntireRow.Copy Destination.Range("A" & (LastRow
+ 1))
End If
End With
End If
Next sht
End Sub

 

[ScottMSP]

Thanks Joel. It appears to have worked!

Union won't work across multiple worksheets. We need to set the Union to
nothing as we change worksheets.

Sub CopyRowsWithNumbersInB()
Dim X As Long
Dim LastRow As Long
Dim Source As Worksheet
Dim Destination As Worksheet
Dim RowsWithNumbers As Range
Set Source = Worksheets("Clinical Nursing")
Set Destination = Worksheets("Sheet2")
For Each sht In Sheets
If UCase(sht.Name) <> ("SHEET2") Then
Set RowsWithNumbers = Nothing
With sht
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For X = 2 To LastRow
If IsNumeric(.Cells(X, "B").Value) And .Cells(X, "B").Value <>
"" Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(X, "B")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X,
"B"))
End If
End If
Next X
If Not RowsWithNumbers Is Nothing Then
LastRow = Destination.Cells(Rows.Count, "B").End(xlUp).Row
RowsWithNumbers.EntireRow.Copy Destination.Range("A" & (LastRow
+ 1))
End If
End With
End If
Next sht
End Sub