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

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

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

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

and probably a couple more. I have 6 report modules based on this code which
I think is bloating the spreadsheet with unnessary code copied with the data.
I would guess that it is erroring out because of the .Range() but that is
only a guess.

Thoughts on how to modify this to work?

Thanks again!!
Andrew

"Joel" wrote:

I see what was wrong. wksPasteTo is a worksheet object and rngPasteTo is a
range object.

originally

from
wksPasteTo.Paste rngPasteTo
to
wksPasteTo.PasteSpecial Paste:=xlPasteValues


correction

from
wksPasteTo.Paste rngPasteTo
to
rngPasteTo.PasteSpecial Paste:=xlPasteValues



"drewship" wrote:

Thanks for replying Joel.

I tried that but the Paste:= is hilighted and a 'Compile error: Named
argument not found' is displayed. Do I need to DIM 'Paste:=xlPasteValues', or
part of it ?

The variable 'rngPasteTo' is the cell location for the row to be pasted and
I can not figure out how to meld it into 'wksPasteTo.PasteSpecial
Paste:=xlPasteValues' without getting an error.

"Joel" wrote:

mke this change

from
wksPasteTo.Paste rngPasteTo
to
wksPasteTo.PasteSpecial Paste:=xlPasteValues

"drewship" wrote:

Hello all.

I have a module with the following code snippet I have been trying to modify:

Set wksPasteTo = Sheets("Closed_Requests")