T
tracks via OfficeKB.com
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("C913,C1517,C1936,C3944,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 = clTffset(d, a)
rngFrom.Copy clTo
End Sub
'===================================
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("C913,C1517,C1936,C3944,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 = clTffset(d, a)
rngFrom.Copy clTo
End Sub
'===================================