Amend Code to work on Older Version e.g Office 2010

[howard]

I have the following code which works on Office 2021. However, one of my users uses Office 2010 and gets a run time error

Kindly amend my Code

Sub Formula()
Dim LR As Long
With Sheets("Macro")
LR = .Cells(.Rows.Count, "L").End(xlUp).Row

.Range("E12:E" & LR + 14).ClearContents
.Range("e12").Formula2R1C1 = "=UNIQUE(R[-11]C[9]:R[2]C[9])"
.Range("e12:E" & LR + 14).Copy
.Range("E12:E" & LR + 14).PasteSpecial xlValues

End With
Application.CutCopyMode = False
End Sub

 

[RoryA]

There is no UNIQUE function in 2010.

 

[howard]

I am aware that there is no unique code. Is there any way to amend code using another code that will give the same result in an older version

 

[RoryA]

Add this function:

Public Function UniqueListFromRange(rgInput As Range) As Variant
   Dim d As Object
   Dim rgArea As Excel.Range
   Dim dataSet
   Dim x As Long
   Dim y As Long

   Set d = CreateObject("Scripting.Dictionary")

   For Each rgArea In rgInput.Areas
      dataSet = rgArea.Value
      If IsArray(dataSet) Then
         For x = 1 To UBound(dataSet)
            For y = 1 To UBound(dataSet, 2)
               If Len(dataSet(x, y)) <> 0 Then d(dataSet(x, y)) = Empty
            Next y
         Next x
      Else
         d(dataSet) = Empty
      End If
   Next rgArea
   UniqueListFromRange = d.Keys
End Function

then change your code to:

Sub Formula()
Dim LR As Long
With Sheets("Macro")
LR = .Cells(.Rows.Count, "L").End(xlUp).Row

.Range("E12:E" & LR + 14).ClearContents
dim v
v = uniquelistfromrange(.range("N1:N14"))
.Range("e12").resize(ubound(v) + 1).value = application.transpose(v)

End With
Application.CutCopyMode = False
End Sub

Formula is not a great name for a routine though.

 

[offthelip]

I am using 2010 and this code works:

Sub test()
Dim LR As Long
Dim Dic As Object
Dim outarr()
With Sheets("Macro")
    LR = .Cells(.Rows.Count, "L").End(xlUp).Row + 14
    ary = .Range(.Cells(1, 12), .Cells(LR, 12))
    
    .Range("E12:E" & LR + 14).ClearContents
    
   Set Dic = CreateObject("Scripting.dictionary")
   For i = 1 To UBound(ary)
      Dic(ary(i, 1)) = ary(i, 1)
   Next i
ReDim outarr(1 To Dic.Count, 1 To 1)
 For i = 0 To Dic.Count - 1
  outarr(i + 1, 1) = Dic.Keys()(i)
 Next i
.Range(.Cells(12, 4), .Cells(11 + Dic.Count, 4)) = outarr
'.Range("e12").Formula = "sum(R[-11]C[9]:R[2]C[9])"
'.Range("e12:E" & LR + 14).Copy
'.Range("E12:E" & LR + 14).PasteSpecial xlValues

End With


End Sub

 

[howard]

Many thanks for your help. Will test your code tomorrow and let you know

 

[howard]

I am using 2010 and this code works:

Sub test()
Dim LR As Long
Dim Dic As Object
Dim outarr()
With Sheets("Macro")
    LR = .Cells(.Rows.Count, "L").End(xlUp).Row + 14
    ary = .Range(.Cells(1, 12), .Cells(LR, 12))
   
    .Range("E12:E" & LR + 14).ClearContents
   
   Set Dic = CreateObject("Scripting.dictionary")
   For i = 1 To UBound(ary)
      Dic(ary(i, 1)) = ary(i, 1)
   Next i
ReDim outarr(1 To Dic.Count, 1 To 1)
 For i = 0 To Dic.Count - 1
  outarr(i + 1, 1) = Dic.Keys()(i)
 Next i
.Range(.Cells(12, 4), .Cells(11 + Dic.Count, 4)) = outarr
'.Range("e12").Formula = "sum(R[-11]C[9]:R[2]C[9])"
'.Range("e12:E" & LR + 14).Copy
'.Range("E12:E" & LR + 14).PasteSpecial xlValues

End With


End Sub

I am using 2010 and this code works:

Sub test()
Dim LR As Long
Dim Dic As Object
Dim outarr()
With Sheets("Macro")
    LR = .Cells(.Rows.Count, "L").End(xlUp).Row + 14
    ary = .Range(.Cells(1, 12), .Cells(LR, 12))
   
    .Range("E12:E" & LR + 14).ClearContents
   
   Set Dic = CreateObject("Scripting.dictionary")
   For i = 1 To UBound(ary)
      Dic(ary(i, 1)) = ary(i, 1)
   Next i
ReDim outarr(1 To Dic.Count, 1 To 1)
 For i = 0 To Dic.Count - 1
  outarr(i + 1, 1) = Dic.Keys()(i)
 Next i
.Range(.Cells(12, 4), .Cells(11 + Dic.Count, 4)) = outarr
'.Range("e12").Formula = "sum(R[-11]C[9]:R[2]C[9])"
'.Range("e12:E" & LR + 14).Copy
'.Range("E12:E" & LR + 14).PasteSpecial xlValues

End With


End Sub

Hi Offthelip your code runs perfectly

I am using 2010 and this code works:

Sub test()
Dim LR As Long
Dim Dic As Object
Dim outarr()
With Sheets("Macro")
    LR = .Cells(.Rows.Count, "L").End(xlUp).Row + 14
    ary = .Range(.Cells(1, 12), .Cells(LR, 12))
   
    .Range("E12:E" & LR + 14).ClearContents
   
   Set Dic = CreateObject("Scripting.dictionary")
   For i = 1 To UBound(ary)
      Dic(ary(i, 1)) = ary(i, 1)
   Next i
ReDim outarr(1 To Dic.Count, 1 To 1)
 For i = 0 To Dic.Count - 1
  outarr(i + 1, 1) = Dic.Keys()(i)
 Next i
.Range(.Cells(12, 4), .Cells(11 + Dic.Count, 4)) = outarr
'.Range("e12").Formula = "sum(R[-11]C[9]:R[2]C[9])"
'.Range("e12:E" & LR + 14).Copy
'.Range("E12:E" & LR + 14).PasteSpecial xlValues

End With


End Sub

Hi Offthelip your code runs perfectly

 

[howard]

Add this function:

Public Function UniqueListFromRange(rgInput As Range) As Variant
   Dim d As Object
   Dim rgArea As Excel.Range
   Dim dataSet
   Dim x As Long
   Dim y As Long

   Set d = CreateObject("Scripting.Dictionary")

   For Each rgArea In rgInput.Areas
      dataSet = rgArea.Value
      If IsArray(dataSet) Then
         For x = 1 To UBound(dataSet)
            For y = 1 To UBound(dataSet, 2)
               If Len(dataSet(x, y)) <> 0 Then d(dataSet(x, y)) = Empty
            Next y
         Next x
      Else
         d(dataSet) = Empty
      End If
   Next rgArea
   UniqueListFromRange = d.Keys
End Function

then change your code to:

Sub Formula()
Dim LR As Long
With Sheets("Macro")
LR = .Cells(.Rows.Count, "L").End(xlUp).Row

.Range("E12:E" & LR + 14).ClearContents
dim v
v = uniquelistfromrange(.range("N1:N14"))
.Range("e12").resize(ubound(v) + 1).value = application.transpose(v)

End With
Application.CutCopyMode = False
End Sub

Formula is not a great name for a routine though.

Hi RoryA

I get a run time message-Type Mismatch and code below is highlighted

 .Range("e12").Resize(UBound(v) + 1).Value = Application.Transpose(v)