VBA: Error when range(variant) condists of only 1 cell

[Manonfire]

Hi,

Below code works perfectly except when the range in colA1 = ws1.range only consist of 1 item(1 row). Then I get Run-time error 13 'mismatch' when running below code.
Is there anyway i can avoid this error and still run the code for ranges consisting of only 1 item?

I have highlighted the error in the code below:


Sub Makro5()

Dim ws1 As Worksheet, colA1 As Variant, r As Long, d1 As Object, d2 As Object
Dim ws2 As Worksheet, colQ2 As Variant, colU2 As Variant, ws3 As Worksheet
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set ws1 = ThisWorkbook.Worksheets("Insert.data")
Set ws2 = ThisWorkbook.Worksheets("Lists")
Set ws3 = ThisWorkbook.Worksheets("Not.found")
colA1 = ws1.Range("A8:A" & ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row)
colQ2 = ws2.Range("P2:P" & ws2.Cells(ws2.Rows.Count, 16).End(xlUp).Row)
colU2 = ws2.Range("T2:T" & ws2.Cells(ws2.Rows.Count, 20).End(xlUp).Row)

For r = 1 To UBound(colQ2)
d1(colQ2(r, 1)) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
Next
For r = 1 To UBound(colU2)
d1(colU2(r, 1)) = vbNullString 'read Sheet2.ColT in dictionary d1.Keys
Next

For r = 2 To UBound(colA1) 'search vals from Sheet1.colA in dictionary d1 <------ Debugs here

If Not d1.Exists(colA1(r, 1)) Then d2(colA1(r, 1)) = vbNullString
Next
If d2.Count > 0 Then ws3.Cells(4, 1).Resize(d2.Count, 1) = Application.Transpose(d2.Keys)





End Sub

[mdmackillop]

The variant where a single cell will be read as String, Long or whatever. Check if it is an array and handle as required

If IsArray(colQ2) Then
For r = 1 To UBound(colQ2, 1)
d1(colQ2(r, 1)) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
Next
Else
d1(colQ2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If

[Manonfire]

The variant where a single cell will be read as String, Long or whatever. Check if it is an array and handle as required

If IsArray(colQ2) Then
For r = 1 To UBound(colQ2, 1)
d1(colQ2(r, 1)) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
Next
Else
d1(colQ2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If


Hi,
Thanks for your reply!
I'm not very good at VBA.... how do i implement your code into mine?
Also i think the problem is regarding colA1 since this is the input data than can consist of only 1 cell. Maybe i'm wrong?

[mdmackillop]

This caters for any variable being a single cell. If you know that this cannot occur, your original code lines without the check can be used.

Sub Makro5()

Dim ws1 As Worksheet, colA1 As Variant, r As Long, d1 As Object, d2 As Object
Dim ws2 As Worksheet, colQ2 As Variant, colU2 As Variant, ws3 As Worksheet
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set ws1 = ThisWorkbook.Worksheets("Insert.data")
Set ws2 = ThisWorkbook.Worksheets("Lists")
Set ws3 = ThisWorkbook.Worksheets("Not.found")
colA1 = ws1.Range("A8:A" & ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row)
colQ2 = ws2.Range("P2:P" & ws2.Cells(ws2.Rows.Count, 16).End(xlUp).Row)
colU2 = ws2.Range("T2:T" & ws2.Cells(ws2.Rows.Count, 20).End(xlUp).Row)


If IsArray(colQ2) Then
For r = 1 To UBound(colQ2, 1)
d1(colQ2(r, 1)) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
Next
Else
d1(colQ2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If


If IsArray(colU2) Then
For r = 1 To UBound(colU2)
d1(colU2(r, 1)) = vbNullString 'read Sheet2.ColT in dictionary d1.Keys
Next
Else
d1(colU2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If


If IsArray(colA1) Then
For r = 2 To UBound(colA1) 'search vals from Sheet1.colA in dictionary d1 <------ Debugs here
If Not d1.Exists(colA1(r, 1)) Then d2(colA1(r, 1)) = vbNullString
Next
Else
d1(colA1) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If

If d2.Count > 0 Then ws3.Cells(4, 1).Resize(d2.Count, 1) = Application.Transpose(d2.Keys)
End Sub

[Manonfire]

Thanks for helping me. It does not debug any more.
But when my input data in sheet 1 only consist of one row(not an array) then the code dosen't do anything. In other words - my code only works if my input range consist of more than 1 cell.

[mdmackillop]

Please post sample workbook Go Advanced / Manage Attachments

[p45cal]

In addition to mdmackillop's suggestion you may also have to do a few more checks; if any of the lists are completely empty (do they have a header?) with the likes of ws1.Range("A8:A" & ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row) you may end up with the ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row part giving you a row number smaller than 8. You'll be processing cell contents above A8. You can circumvent this in a number of ways but here's one:
lr = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
If lr > 7 Then colA1 = ws1.Range("A8:A" & lr)

lr = ws2.Cells(ws2.Rows.Count, 16).End(xlUp).Row
If lr > 1 Then colQ2 = ws2.Range("P2:P" & lr)

lr = ws2.Cells(ws2.Rows.Count, 20).End(xlUp).Row
If lr > 1 Then colU2 = ws2.Range("T2:T" & lr)
Then as well as testing for arrays, you can test for the likes of colA1 etc. being Empty.

A sample workbook would be really helpful.

[mdmackillop]

Also, what is Sheet 1?

But when my input data in sheet 1 only consist of one row

[Manonfire]

Hi,
Thanks again but my file is too big to upload.
I found that the first row in my range (A8-end sheet 1) is not being analyzed. The rest of the range is though.

[Manonfire]

Sorry. That would be the sheet that i call "input.data"

[Manonfire]

Hi guys,
I discovered that all i had to do was to change my range from A8 to A7: "colA1 = ws1.Range("A7:A" & ws1.Cells"


Sub Makro5()

Dim ws1 As Worksheet, colA1 As Variant, r As Long, d1 As Object, d2 As Object
Dim ws2 As Worksheet, colQ2 As Variant, colU2 As Variant, ws3 As Worksheet
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set ws1 = ThisWorkbook.Worksheets("Insert.data")
Set ws2 = ThisWorkbook.Worksheets("Lists")
Set ws3 = ThisWorkbook.Worksheets("Not.found")
colA1 = ws1.Range("A7:A" & ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row)
colQ2 = ws2.Range("P2:P" & ws2.Cells(ws2.Rows.Count, 16).End(xlUp).Row)
colU2 = ws2.Range("T2:T" & ws2.Cells(ws2.Rows.Count, 20).End(xlUp).Row)


If IsArray(colQ2) Then
For r = 1 To UBound(colQ2, 1)
d1(colQ2(r, 1)) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
Next
Else
d1(colQ2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If


If IsArray(colU2) Then
For r = 1 To UBound(colU2)
d1(colU2(r, 1)) = vbNullString 'read Sheet2.ColT in dictionary d1.Keys
Next
Else
d1(colU2) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If


If IsArray(colA1) Then
For r = 2 To UBound(colA1) 'search vals from Sheet1.colA in dictionary d1
If Not d1.Exists(colA1(r, 1)) Then d2(colA1(r, 1)) = vbNullString
Next
Else
d1(colA1) = vbNullString 'read Sheet2.ColP in dictionary d1.Keys
End If

If d2.Count > 0 Then ws3.Cells(4, 1).Resize(d2.Count, 1) = Application.Transpose(d2.Keys)
End Sub



It works perfectly now!
Thank you so much :hi:

[mdmackillop]

Please mark your thread Solved using the Thread Tools dropdown

[snb]

Why so complicated ?


sub M_snb()
sn=sheets("Insert.data").cells(1).currentregion.columns(1)
sp=sheets("Lists").cells(1).currentregion

for j =1 to ubound(sn)
for jj=1 to ubound(sp)
if sn(j,1)=sp(jj,16) or sn(j,1)=sp(jj,20) then exit for
next
if jj> ubound(sp) then c00=c00 & "|" & sn(j,1)
next

if c00<>"" then
sn=split(c00,"|")
sheets("notfound").cells(4,1).resize(ubound(sn)+1)=application.transpose(sn)
end if
end sub