I am not very good writing the code myself so I use the wizaeds to get me
started then try to modify them for my purposes. In this case I think I
confused myself a bit. Thanks for all your help!! The code is perfect!!

Andrew

"Joel" wrote:

I re-wrote the code the way I usually write my code. I can see you use
recorded to get some of your code. Inever use the recorded code directly. I
always modify the recorded code. some time it is quicker for me to use the
recorded but I I avoi using the select method in my macros unless excel only
except the method with the select.

Looking at the modified code I found your problem. Half you code is working
with one worksheet and the other half with a different worksheet. You need
to be using only one worksheet in this macro.

with Sheets("All_Report")
.Range("N1") = Format(lodate, "M/D/YYYY")
.Range("O1") = Format(hidate, "M/D/YYYY")
.Columns("C:D").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
end with



"drewship" wrote:

Ok...not sure why removing the header lines (only 2 lines) made a difference,
but after I commented out the Delete Blank Rows code block, it works
correctly, and quickly.

Thank you very much for your help!! Merging my code with yours will make it
easier to make changes and additions in the future and hopefully reduce
spreadsheet bloat due to unneeded code in the reports.

Andrew


"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