hi all,
This is the code i have accumulated with much help, when i execute the
program code i get am ERROR 9 subscript out of range message. i have checked
my sheet tabs of unshown spaces, check the code in the private sub still
cannot get rid error. The error occurs at the copyTOSummary statement after
the if statement. you have any work arounds would be appreciated.
Rick.

Sub CO()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range

Set rng1 = Worksheets("DAILY CRANE INFO").Range("I7")

With Worksheets("CRANE WT SUMMARY")
Set rng2 = .Cells(.rows.Count, 1).End(xlUp)

End With

If month(rng1) month(rng2) Then

copyToSummary Worksheets("CRANE WT SUMMARY").Range("A2:G39"),
Worksheets("CALENDAR SUMMARY").Range("B2"), 3, month(rng1)
Worksheets("CRANE WT SUMMARY").Range("A7:G31").Select
Selection.ClearContents

Call Sheet2.TEST

Else: Call Sheet2.TEST

End If

End Sub


Sub TEST()
Dim DestCell As Range

With Worksheets("CRANE WT SUMMARY")
Set DestCell = .Cells(.rows.Count, 1).End(xlUp).Offset(1, 0)
End With

With Worksheets("DAILY CRANE INFO")
.Range("I7").Copy
DestCell.PasteSpecial Paste:=xlPasteValues


.Range("AA15:AF15").Copy
DestCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues

End With

Worksheets("DAILY PRODUCTION").Select
ActiveSheet.Range("C9:D13,C15:D17,C19:D36,C39:D44, F9:G13,F15:G17,
F19:G36,F38:G44,E15:E17,E24:E27,E38:E44").Select
Selection.ClearContents
ActiveSheet.Range("C1").Select



End Sub




'====================================
'rngFrom: the range to be copied
'clTo: the upper-left-corner cell of the summary range
'across: the number of columns across
'month: the month to be copied

Private Sub copyToSummary(ByVal rngFrom As Excel.Range, ByVal clTo As Excel.
Range, across As Integer, ByVal month As Integer)

Dim cols As Integer, rows As Integer, a As Integer, d As Integer

cols = rngFrom.Columns.Count
rows = rngFrom.rows.Count

a = ((month - 1) Mod across) * cols
d = (Fix((month - 1) / across)) * rows

Set clTo = clTo.Offset(d, a)

rngFrom.Copy clTo

End Sub

'===================================

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200611/1