I apologise for not including the complete code...I am never sure how much
code is enough...or too much. The complete code for the Case block is below
with "Sheets("All_Report").Activate" setting the active sheet...at least that
is how I understood it:

'format and review new report
Sheets("All_Report").Activate
Range("N1") = Format(lodate, "M/D/YYYY")
Range("O1") = Format(hidate, "M/D/YYYY")
Columns("C:D").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("A:Q").Columns.AutoFit

LR = Cells(Rows.Count, "B").End(xlUp).Row
For i = 3 To LR
If Not IsEmpty(Cells(i, "B")) Then
Select Case Destination.Cells(i, "B").Value
Case "Complete"
icolor = 10
fcolor = 2
Case "In Progress"
icolor = 8
Case "Items On Order"
icolor = 6
Case "Researching"
icolor = 3
fcolor = 2
Case "Closed"
icolor = 5
fcolor = 2
Case ""
icolor = 2
End Select

With Destination.Cells(i, "B")
.Interior.ColorIndex = icolor
.Font.ColorIndex = fcolor
End With

End If
fcolor = xlColorIndexAutomatic
Next i

Range("A3").Select


I am looking at the rest of your reply....


"Joel" wrote:

the following code sets th elast line

' Set wksPasteTo = Sheets("AllName1") set prior to this code block
With wksPasteTo
'ActiveSheet.Unprotect pw
LR = .Range("C" & Rows.Count).End(xlUp).Row

It is taking the last line of data in column C. Rows.count is the last row
of the worksheet (65536). the XL commands can be duplicated using the
keyboardf

xlup - Shift-Cntl - Up Arrow
xldown - Shift-Cntl - Down Arrow
xltoleft - Shift-Cntl - left Arrow
xlright - Shift-Cntl - right Arrow


So if you select cell C100 with mouse and press the keys Shft-Cntl and then
the up arrow you will get the last row of data.


the new code you posted in the Cae Select aren't referencing a workshet.
they are using the active worksheet which I can't tell which worksheet is the
active worksheet. You should always specify a worksheet to prevent errors in
the code like the first part of the code that has a "With wksPasteTo". the
all the RANGE statement with a period in front is automatically using the
worksheet wksPasteTo. the code in the select statement has Range without the
period in front so I can't tell which is the active worksheet.

"drewship" wrote:

Below is the working code to change the colors of the Status cells so all
that is left for the moment is to figure out why the merged code is starting
the paste on line 32. Hopefully you or someone else can help with that. I
have tried steppiing through the code but can't see the problem:

LR = Cells(Rows.Count, "B").End(xlUp).Row
For i = 3 To LR
If Not IsEmpty(Cells(i, "B")) Then
Select Case Destination.Cells(i, "B").Value
Case "Complete"
icolor = 10
fcolor = 2
Case "In Progress"
icolor = 8
Case "Items On Order"
icolor = 6
Case "Researching"
icolor = 3
fcolor = 2
Case "Closed"
icolor = 5
fcolor = 2
Case ""
icolor = 2
' Case Else: icolor = 0
End Select

With Destination.Cells(i, "B")
.Interior.ColorIndex = icolor
.Font.ColorIndex = fcolor
End With

End If
fcolor = xlColorIndexAutomatic
Next i

Thanks!!
Andrew

"drewship" wrote:

Thanks Joel!!

I took what you provided and made some modifications so it would work in a
manner I needed.

' Set wksPasteTo = Sheets("AllName1") set prior to this code block
With wksPasteTo
'ActiveSheet.Unprotect pw
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set rngPasteTo = wksPasteTo.Range("A3" & (LR + 1))

With Sheets("Distribution")
'LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = .Range("C65536").End(xlUp).Row

' For x = LastRow To 1 Step -1
For x = 3 To LastRow
' If .Range("B" & x).Value = "Closed" Then
If IsDate(.Cells(x, "C").Value) And .Cells(x, "C").Value < ""
And .Cells(x, "C").Value = lodate And .Cells(x, "C").Value <= hidate Then
If RowsWithNumbers Is Nothing Then
Set RowsWithNumbers = .Cells(x, "C")
Else
Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(x, "C"))
End If
End If
Next
If Not RowsWithNumbers Is Nothing Then
RowsWithNumbers.EntireRow.Copy
' .Range("B" & x).EntireRow.Copy

rngPasteTo.PasteSpecial Paste:=xlPasteValues
Set rngPasteTo = rngPasteTo.Offset(1)

End If
' Next x
End With
End With

There are 2 things that need some work. This code block in itself now pastes
the rows starting at row 32 on the temporary sheet "wksPasteTo". Still trying
to figure that out, but as a temporary workaround, I have added the following
code to delete the blank lines before the rows are copied to the actual
report:

' Delets blank rows
Cells.Select

On Error GoTo Exits:

If Selection.Rows.Count 1 Then
Set rng = Selection
Else
Set rng = Range(Rows(1),
Rows(ActiveSheet.Cells.SpecialCells(xlCellTypeLast Cell).Row()))
End If
RwCnt = 0
For Rw = rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(rng.Rows(Rw). EntireRow)
= 0 Then
rng.Rows(Rw).EntireRow.Delete
RwCnt = RwCnt + 1
End If
Next Rw
Exits:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Although this works, it increases processing time for the report.

The last thing I need is to change the color of the status cells (column B)
based on their content. In another sheets code, I have the following block I
think could be reworked for my need:

If Not Intersect(Target, Range("B:B")) Is Nothing Then
Select Case Target.Value
Case "Complete"
If Cells(Target.Row, "D").Value < "" Then
If MsgBox("Completion Date already exists. Update the date
to today?", vbYesNo + vbQuestion) = vbNo Then GoTo ExitPoint
End If

Cells(Target.Row, "D").Value = Date
icolor = 10
fcolor = 2
Case "In Progress"
Cells(Target.Row, "D").Value = ""
icolor = 8
Case "Items On Order"
Cells(Target.Row, "D").Value = ""
icolor = 6
Case "Researching"
Cells(Target.Row, "D").Value = ""
icolor = 3
fcolor = 2
Case "Closed"
Cells(Target.Row, "D").Value = Cells(Target.Row, "D")
icolor = 5
fcolor = 2
Case ""
icolor = 2
End Select
With Target
.Interior.ColorIndex = icolor
.Font.ColorIndex = fcolor
End With
ActiveSheet.Protect pw, UserInterfaceOnly:=True

End If

Target row D is a date field I do not need in this use of Case, so I am
looking for a way to get this to work. Is there an easier way? Thoughts??

Thanks again!!!!

"Joel" wrote:

You didn't specify the error you are getting. I don't know wherre you are
decaring ws2, ws3, ... I suspect the sheets specified in the ranges are non
on the same page and causing an error. See my comments below and my new
code. I put the destination sheet in only one place in the code so you only
have to make one change when going from one module to a 2nd module.

Set wksPasteTo = Sheets("Closed_Requests")

Remove Line - No need to select
---------------------------------------
Sheets("Closed_Requests").Select
-----------------------------------

'ActiveSheet.Unprotect pw

Add sheet reference
------------------------------------------------
from
LR = Range("B" & Rows.Count).End(xlUp).Row
to
LR = wksPasteTo.Range("B" & Rows.Count).End(xlUp).Row

-------------------------------------------------


Set rngPasteTo = wksPasteTo.Range("A" & (LR + 1))

move inside with and add page reference
-------------------------------------------------
Sheets("Distribution").Select
LastRow = Range("A65536").End(xlUp).Row
-------------------------------------------------

With Sheets("Distribution")
-------------------------------------------------
from
LastRow = Range("A65536").End(xlUp).Row
to
LastRow = .Range("A65536").End(xlUp).Row
------------------------------------------

For x = LastRow To 1 Step -1
If Range("B" & x).Value = "Closed" Then

add sheet reference
------------------------------------------
from
Range("B" & x).EntireRow.Copy
to
.Range("B" & x).EntireRow.Copy
------------------------------------------

Don't need with - sheet already specified in range above
With Sheets("Closed_Requests")
rngPasteTo.PasteSpecial Paste:=xlPasteValues
Set rngPasteTo = rngPasteTo.Offset(1)
End With

remove sheet refernce - already in with
------------------------------------------
from
Sheets("Distribution").Range("B" & x).EntireRow.Delete
to
.Range("B" & x).EntireRow.Delete
------------------------------------------
End If
Next x
End With




New Code

Set wksPasteTo = Sheets("Closed_Requests")
with wksPasteTo
'ActiveSheet.Unprotect pw
LR = .Range("B" & Rows.Count).End(xlUp).Row
Set rngPasteTo = wksPasteTo.Range("A" & (LR + 1))

with Sheets("Distribution")
LastRow = .Range("A65536").End(xlUp).Row

For x = LastRow To 1 Step -1
If .Range("B" & x).Value = "Closed" Then
.Range("B" & x).EntireRow.Copy

rngPasteTo.PasteSpecial Paste:=xlPasteValues
Set rngPasteTo = rngPasteTo.Offset(1)

.Range("B" & x).EntireRow.Delete
End If
Next x
End With



"drewship" wrote:

Thanks!! That works for the first part of my question.

For the second part, I have tried:

With ws2
.Range("A3:G" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets("All_Report").Range("A3").PasteSpecial Paste:=xlPasteValues

With ws2
.Range("A3:G" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets("All_Report").Range("A3") PasteSpecial Paste:=xlPasteValues