Error 91 Object variable or With block variable not set

P

PGNewbie

New Member
Joined
Feb 6, 2020
Messages
41
Office Version
  1. 365
Platform
  1. Windows
I'm getting runtime error 91 when trying to run this code. The code is designed to compare two columns with another set of columns in another work book and then return the results from a third column if there is a match.
VBA code
Sub InsertDeviceName_NewBook()

Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
Dim wbnew As Workbook
Dim c As Range, FR As Variant
Dim d As Range
Dim e As Range, rng1 As Range, rng2 As Range
Dim lr1 As Long, lr2 As Long


Application.ScreenUpdating = False


Set w2 = Workbooks("Book2.xlsx").ActiveSheet
Set w1 = Workbooks("Book1.xlsx").ActiveSheet



w1.Range("B:D").Copy
Set wbnew = Workbooks.Add
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Name = w1.Name
Set wsnew = wbnew.ActiveSheet
lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row

wsnew.Range("$B:$C").RemoveDuplicates Columns:=Array(1), _
Header:=xlNo

wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With wsnew.Sort
.SetRange Range("A1:C" & lr1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply


Columns("B:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

Range("B1").Select
ActiveCell.FormulaR1C1 = "Device Name"

Dim lr3 As Long

lr3 = wsnew.Cells(Rows.count, 1).End(xlUp).Row

rng1 = wsnew.Range("C2:D" & lr3) '''causes error
rng2 = w2.Range("C2:D" & lr2)

For Each d In rng3
FR = Application.Match(d, rng2)
If IsNumeric(FR) Then
d.Offset(, -1).Value = w2.Range("B" & FR).Value
End If

Next d

Range("E1").Select
ActiveCell.FormulaR1C1 = "State"

For Each e In wbnew.Sheets(1).Range("C2", wbnew.Sheets(1).Range("C" & Rows.count).End(xlUp))
FR = Application.Match(e, w1.Columns("C"), 0)
If IsNumeric(FR) Then
e.Offset(, 2).Value = w1.Range("K" & FR).Value
End If

Next e

Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select

End With


Range("A1:E1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With

Application.ScreenUpdating = True

End Sub
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
What line does it error on (is it possible to put your code in code tags in your future postings, as it makes it much easier to read (and copy).... you can see how to do this in my signature block).
 
Upvote 0
VBA Code: 
Sub InsertDeviceName_NewBook()

Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
Dim wbnew As Workbook
Dim c As Range, FR As Variant
Dim d As Range
Dim e As Range, rng1 As Range, rng2 As Range
Dim lr1 As Long, lr2 As Long


Application.ScreenUpdating = False


Set w2 = Workbooks("Book2.xlsx").ActiveSheet
Set w1 = Workbooks("Book1.xlsx").ActiveSheet



w1.Range("B:D").Copy
Set wbnew = Workbooks.Add
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Name = w1.Name
Set wsnew = wbnew.ActiveSheet
lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row


wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With wsnew.Sort
.SetRange Range("A1:C" & lr1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply


Columns("B:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

Range("B1").Select
ActiveCell.FormulaR1C1 = "Device Name"

Dim lr3 As Long

lr3 = wsnew.Cells(Rows.count, 1).End(xlUp).Row

wsnew.Range("C2:D" & lr3)[/COLOR]      'causes error
rng2 = w2.Range("C2:D" & lr2)

For Each d In rng3
FR = Application.Match(d, rng2)
If IsNumeric(FR) Then
d.Offset(, -1).Value = w2.Range("B" & FR).Value
End If

Next d

Range("E1").Select
ActiveCell.FormulaR1C1 = "State"

For Each e In wbnew.Sheets(1).Range("C2", wbnew.Sheets(1).Range("C" & Rows.count).End(xlUp))
FR = Application.Match(e, w1.Columns("C"), 0)
If IsNumeric(FR) Then
e.Offset(, 2).Value = w1.Range("K" & FR).Value
End If

Next e

Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select

End With


Range("A1:E1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With

Application.ScreenUpdating = True

End Sub
 
Upvote 0
MARK858 said:
What line does it error on (is it possible to put your code in code tags in your future postings, as it makes it much easier to read (and copy).... you can see how to do this in my signature block).
Click to expand...
Thanks Mark858. I have added the code in the code tags. Sorry I didn't know how to do that before :)
 
Upvote 0
Rich (BB code): 
        Set rng1 = wsnew.Range("C2:D" & lr3)         '''causes error
        Set rng2 = w2.Range("C2:D" & lr2)
I also can't see rng3 defined anywhere :unsure: before
VBA Code: 
For Each d In rng3
 
Last edited:
Upvote 0
MARK858 said:
Rich (BB code): 
        Set rng1 = wsnew.Range("C2:D" & lr3)         '''causes error
        Set rng2 = w2.Range("C2:D" & lr2)
I can't see rng3 defined anywhere :unsure:
Click to expand...
Sorry it got cut off. I renamed it to rng1 which was the original name

VBA Code: 
Sub InsertDeviceName_NewBook()

Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
Dim wbnew As Workbook
Dim c As Range, FR As Variant
Dim d As Range
Dim e As Range, rng1 As Range, rng2 As Range
Dim lr1 As Long, lr2 As Long


Application.ScreenUpdating = False


Set w2 = Workbooks("Book2.xlsx").ActiveSheet
Set w1 = Workbooks("Book1.xlsx").ActiveSheet



w1.Range("B:D").Copy
Set wbnew = Workbooks.Add
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Name = w1.Name
Set wsnew = wbnew.ActiveSheet
lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row


wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With wsnew.Sort
.SetRange Range("A1:C" & lr1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply


Columns("B:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

Range("B1").Select
ActiveCell.FormulaR1C1 = "Device Name"

Dim lr3 As Long

lr3 = wsnew.Cells(Rows.count, 1).End(xlUp).Row

rng1 = wsnew.Range("C2:D" & lr3)      'causes error
rng2 = w2.Range("C2:D" & lr2)

For Each d In rng1
FR = Application.Match(d, rng2)
If IsNumeric(FR) Then
d.Offset(, -1).Value = w2.Range("B" & FR).Value
End If

Next d

Range("E1").Select
ActiveCell.FormulaR1C1 = "State"

For Each e In wbnew.Sheets(1).Range("C2", wbnew.Sheets(1).Range("C" & Rows.count).End(xlUp))
FR = Application.Match(e, w1.Columns("C"), 0)
If IsNumeric(FR) Then
e.Offset(, 2).Value = w1.Range("K" & FR).Value
End If

Next e

Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select

End With


Range("A1:E1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With

Application.ScreenUpdating = True

End Sub
 
Upvote 0
You still haven't added the word Set in front of the 2 lines that I posted ;)
 
Upvote 0
MARK858 said:
You still haven't added the word Set in front of the 2 lines that I posted ;)
Click to expand...
I feel so silly! Thank you that removed the error. I am not able to get results for this code, should I repost this code with a new question?
 
Upvote 0
Won't be any harm in posting a new question (especially as I am just about to get something to eat :) )
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
VBA question
Replies
6
Views
111
Skyybot
Skyybot
I
  • Solved
FILTER formula criteria based of a variable with VBA
Replies
2
Views
277
ItalianPlatinum
I
K
  • Question Question
VBA code to only affect blank cells
Replies
2
Views
422
ChrisFoster
C
T
  • Question Question
VBA compare values on different sheets.
Replies
5
Views
695
rlv01
R
sparky2205
  • Solved
Object variable or With Block variable not set
2
Replies
19
Views
508
Alex Blakenburg
A

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top