Conditional copy from multiple sheets to one sheet
 

Hi,

Please forgive the repost, but I'm hoping someone will please follow-up with
a solution to the problem.

I have a workbook with several sheets for each employee. There is a
segment in the same section of each worksheet that contains a list of items
with a completed date. What I would like to happen is if the completed
blank is null anywhere in each list, that item with the due date to be
placed on a new worksheet - as a summary of all incomplete items for each
employee.

An example:

I would like for it to gather all the lines from the same segment specifed
in each worksheet that do not have a date completed in a column of the
segment and then place all those on one sheet.

sheet1
name task due completed
emp1 activity 1/1/09 1/15/09
emp1 activity 2/1/09

sheet2
emp2 activity 3/1/09
emp2 activity 4/1/09 4/15/09

sheet"Blanks" would be
emp1 activity 2/1/09
emp2 activity 3/1/09

Joel supplied the following code, but I can't get it to completely work -
the new sheet will add to workbook, but no lines are copied.
The code below wil check every sheet in the workbook in the range "A1:D15"
for a blnak cell and if it find one copies the endtire row to a new
worksheet
called Blanks.

Sub findblanks()

Segment = "A1:d15"
Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Blanks"
NewRowCount = 1
For Each sht In Sheets
If sht.Name < "Blanks" Then
Set SearchRange = sht.Range(Segment)
For RowCount = 1 To SearchRange.Rows.Count
For ColCount = 1 To SearchRange.Columns.Count
If SearchRange.Cells(RowCount, ColCount) = "" Then
SearchRange.Rows(RowCount).Copy _
Destination:=NewSht.Rows(NewRowCount)
NewRowCount = NewRowCount + 1
Exit For
End If
Next ColCount
Next RowCount
End If
Next sht
End Sub


Thanks in advance for any help.

Pam

Conditional copy from multiple sheets to one sheet
 

Well, I tried this code and didn't have much success with it either. I
have all of the options on to make sure that variables are declared and
such (VERY important), so I got numerous errors until I changed it to
this:
Sub findblanks()

Dim Segment As Range, NewSht As Excel.Worksheet
Dim NewRowCount As Integer, sht As Excel.Worksheet
Dim SearchRange As Range
Dim RowCount As Integer, ColCount As Integer

Set Segment = Range("A1:D15")
Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Blanks"
NewRowCount = 1
For Each sht In Sheets
If sht.Name < "Blanks" Then
Set SearchRange = Segment
For RowCount = 1 To SearchRange.Rows.Count
For ColCount = 1 To SearchRange.Columns.Count
If SearchRange.Cells(RowCount, ColCount) = "" Then
SearchRange.Rows(RowCount).Copy
Destination:=NewSht.Rows(NewRowCount)
NewRowCount = NewRowCount + 1
Exit For
End If
Next ColCount
Next RowCount
End If
Next sht

End Sub

Not sure why people don't want to Dim their vars, but even that didn't
work like you are wanting (at least I don't think so). It filled out the
entire worksheet with the same sets of data for some reason. I'll have
to look into it some more to figure out why...


--
gmorris
------------------------------------------------------------------------
gmorris's Profile: http://www.thecodecage.com/forumz/member.php?userid=245
View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=91772

Conditional copy from multiple sheets to one sheet
 

Thank you, gmorris, for the prompt reply and help. I greatly appreciate it
as I've spent a great deal of time trying to make this work.

Thanks again,
Pam

"gmorris" wrote in message
...

Well, I tried this code and didn't have much success with it either. I
have all of the options on to make sure that variables are declared and
such (VERY important), so I got numerous errors until I changed it to
this:
Sub findblanks()

Dim Segment As Range, NewSht As Excel.Worksheet
Dim NewRowCount As Integer, sht As Excel.Worksheet
Dim SearchRange As Range
Dim RowCount As Integer, ColCount As Integer

Set Segment = Range("A1:D15")
Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Blanks"
NewRowCount = 1
For Each sht In Sheets
If sht.Name < "Blanks" Then
Set SearchRange = Segment
For RowCount = 1 To SearchRange.Rows.Count
For ColCount = 1 To SearchRange.Columns.Count
If SearchRange.Cells(RowCount, ColCount) = "" Then
SearchRange.Rows(RowCount).Copy
Destination:=NewSht.Rows(NewRowCount)
NewRowCount = NewRowCount + 1
Exit For
End If
Next ColCount
Next RowCount
End If
Next sht

End Sub

Not sure why people don't want to Dim their vars, but even that didn't
work like you are wanting (at least I don't think so). It filled out the
entire worksheet with the same sets of data for some reason. I'll have
to look into it some more to figure out why...


--
gmorris
------------------------------------------------------------------------
gmorris's Profile: http://www.thecodecage.com/forumz/member.php?userid=245
View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=91772