Run Time error 424 Object Required

[Casey]

Hi,
I don't understand why I'm getting this error. I have declared all th
variables and I have tried using and not using the Set statement. Coul
use some help.
The error is:
Run Time error 424 Object Required

Here is the Code: I've commented out the error handling to find th
error.

Option Explicit

Sub CreateRoomSheets()

Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range, rngNR As Range, rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range, rng5 As Range, rCell As Range


Set WB = ThisWorkbook
Set SH = WB.Sheets("Room Blank")
Set rng = WB.Sheets("Room List").Range("RoomNo")
Set rngNR = WB.Sheets("RoomTypes").Range("ItemTable")
Set rng1 = WB.Sheets("Room List").Range("RoomName")
Set rng2 = WB.Sheets("Room List").Range("RoomTypeCol")
Set rng3 = WB.Sheets("Room List").Range("RoomRefCol")

'On Error GoTo RET
Application.ScreenUpdating = False


For Each rCell In rng.Cells
Set rng4 = Excel.WorksheetFunction.HLookup(rCell.Offset(0
3).Value, rngNR, 1, False) '<====ERROR
Set rng5 = Range(rng4.Offset(1, 0), rng4.Offset(51, 1))
rng5.Copy
With rCell
SH.Copy After:=WB.Sheets(WB.Sheets.Count)
With ActiveSheet
.Name = rCell.Value
.Range("B2") = rCell.Value
.Range("B3") = rCell.Offset(0, 1).Value
.Range("B4") = rCell.Offset(0, 2).Value
.Range("A6").PasteSpecial Paste:=xlPasteValues
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End With
Next rCell

'RET:
Application.ScreenUpdating = True
End Su

 

[Guest]

Hlookup returns a value not a range object. You would probably be better off
using a find function.

set rng4 = rngNR.Find(What:=rCell.Offset(0,3).Value, _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
MatchCase:=False)
if rng4 is nothing then
msgbox "Sorry, The item was not found"
else
'continue on with your code...

 

[Guest]

Hlookup returns a value, not a range object.


Match will return an offset into the range. You can use that to pick up the
cell

if rngNr is a single row like
set rngNr = rows(6)

Dim res as Variant
res = Application.Match(rCell.Offset(0,3).Value, rngNR,0)
if not iserror(res) then
set rng4 = rngNr(1,res)

 

[Casey]

Jim,
Thank you. I got an additional 1004 error when the code went to paste
the rng5 information into A6 of the ActiveSheet, so I moved the
rng5.copy line and everthing worked great.
Thank you for the lesson on the HLookup returning a value and not a
range. That made it click for me.

For the benefit of others the corrected Code:

Option Explicit

Sub CreateRoomSheets()

Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range, rngNR As Range, rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range, rng5 As Range, rCell As Range


Set WB = ThisWorkbook
Set SH = WB.Sheets("Room Blank")
Set rng = WB.Sheets("Room List").Range("RoomNo")
Set rngNR = WB.Sheets("RoomTypes").Range("ItemTable")
Set rng1 = WB.Sheets("Room List").Range("RoomName")
Set rng2 = WB.Sheets("Room List").Range("RoomTypeCol")
Set rng3 = WB.Sheets("Room List").Range("RoomRefCol")

On Error GoTo RET
Application.ScreenUpdating = False


For Each rCell In rng.Cells 'Excel.WorksheetFunction
Set rng4 = rngNR.Find(What:=rCell.Offset(0, 3).Value, _
LookAt:=xlWhole, LookIn:=xlFormulas,
MatchCase:=False)
If rng4 Is Nothing Then
MsgBox "Sorry, The item was not found"
End If
Set rng5 = Range(rng4.Offset(1, 0), rng4.Offset(51, 1))
rng5.Copy
With rCell
SH.Copy After:=WB.Sheets(WB.Sheets.Count)
With ActiveSheet
..Name = rCell.Value
..Range("B2") = rCell.Value
..Range("B3") = rCell.Offset(0, 1).Value
..Range("B4") = rCell.Offset(0, 2).Value
rng5.Copy
..Range("A6").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End With
Next rCell

RET:
Application.ScreenUpdating = True
End Sub

 

[Casey]

Tom,
Thank you for your reply. I always appreciate the conciseness (hope
that's a real word) of your code.
I got a great bit of code from you today in an answer you gave to
another OP, regarding adding up a filtered list. I have needed to do
that on a number of worksheets and knew the built-in Subtotal function
would do it but never could find an example of the Autofilter and
Subtotal used together to get there. Great code.

 

[Guest]

If rng4 is not set then the rest of the code will bomb out. You might want to
add an exit if the item is not found...

If rng4 Is Nothing Then
MsgBox "Sorry, The item was not found"
exit sub
End If

 

[Casey]

Jim,
Thanks. I not very good at anticipating errors and coming up with ways
to handle them yet. I often overlook that stuff. Question; since I have
an Error handler that goes to RET, do I still need the extra? And if I
do, should I exit to RET to reset ScreenUpdating? Something like:

If rng4 Is Nothing Then
MsgBox "Sorry, The item was not found"
GoTo RET 'instead of End Sub?????
End If

 

[Guest]

With the exception of the error handler I avoid using goto's as they can
become a real nightmare to debug. If it was me I would do something like this
with an if else statement. It skips all of the code if rng4 is nothing and
goes right to the end... That being said a goto will work.

Option Explicit

Sub CreateRoomSheets()

Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range, rngNR As Range, rng1 As Range, rng2 As Range
Dim rng3 As Range, rng4 As Range, rng5 As Range, rCell As Range


Set WB = ThisWorkbook
Set SH = WB.Sheets("Room Blank")
Set rng = WB.Sheets("Room List").Range("RoomNo")
Set rngNR = WB.Sheets("RoomTypes").Range("ItemTable")
Set rng1 = WB.Sheets("Room List").Range("RoomName")
Set rng2 = WB.Sheets("Room List").Range("RoomTypeCol")
Set rng3 = WB.Sheets("Room List").Range("RoomRefCol")

On Error GoTo RET
Application.ScreenUpdating = False


For Each rCell In rng.Cells 'Excel.WorksheetFunction
Set rng4 = rngNR.Find(What:=rCell.Offset(0, 3).Value, _
LookAt:=xlWhole, LookIn:=xlFormulas,
MatchCase:=False)
If rng4 Is Nothing Then
MsgBox "Sorry, The item was not found"
Else
Set rng5 = Range(rng4.Offset(1, 0), rng4.Offset(51, 1))
rng5.Copy
With rCell
SH.Copy After:=WB.Sheets(WB.Sheets.Count)
With ActiveSheet
.Name = rCell.Value
.Range("B2") = rCell.Value
.Range("B3") = rCell.Offset(0, 1).Value
.Range("B4") = rCell.Offset(0, 2).Value
rng5.Copy
.Range("A6").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End With
Next rCell
end if
RET:
Application.ScreenUpdating = True
End Sub

 

[Casey]

Jim,
I like the else statement. I will go that route. Thanks again for all
the help and advice.