Code error

[Rohith1324]

Hi

I have excel sheet with 2 Columns

column 1 will have repetative values - 1 Value might repeat almost 50 - 100 Time and in the second Column the it will have the numbers

below is code i'm using and in some system the code is getting executed and in some the code is not getting executed, can someone please help :

Dim oDict As Dictionary
Dim sData() As Variant
Dim LastRow As Long
Dim i As Variant
Dim Cnt As Variant

Set oDict = CreateObject("Scripting.Dictionary")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow
If Not oDict.Exists(Cells(i, "A").Value) Then
Cnt = Cnt + 1
ReDim Preserve sData(1 To 2, 1 To Cnt)
sData(1, Cnt) = Cells(i, "A").Value
sData(2, Cnt) = Cells(i, "B").Value
oDict.Add Cells(i, "A").Value, Cnt
Else
sData(2, oDict.Item(Cells(i, "A").Value)) = _
sData(2, oDict.Item(Cells(i, "A").Value)) & _
", " & Cells(i, "B").Value
End If
Next i

Range("G1").Value = Range("A1").Value
Range("H1").Value = Range("B1").Value
Range("I1").Value = "Circle"
Range("J1").Value = "HW/SW"

'Transfer the contents of the array to a worksheet range, starting at D2
Range("G2").Resize(UBound(sData, 2), 2).Value = _
WorksheetFunction.Transpose(sData)

End Sub

 

[Fluff]

Try it like this instead

Sub Rohith()
   Dim oDict As Object
   Dim sData() As Variant
   Dim LastRow As Long
   Dim i As Variant
   Dim Cnt As Variant
   
   Set oDict = CreateObject("Scripting.Dictionary")
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   ReDim sData(1 To LastRow, 1 To 2)
   For i = 2 To LastRow
      If Not oDict.Exists(Cells(i, "A").Value) Then
         Cnt = Cnt + 1
         sData(Cnt, 1) = Cells(i, "A").Value
         sData(Cnt, 2) = Cells(i, "B").Value
         oDict.Add Cells(i, "A").Value, Cnt
      Else
         sData(oDict.Item(Cells(i, "A").Value), 2) = _
         sData(oDict.Item(Cells(i, "A").Value), 2) & _
         ", " & Cells(i, "B").Value
      End If
   Next i
   
   Range("G1").Value = Range("A1").Value
   Range("H1").Value = Range("B1").Value
   Range("I1").Value = "Circle"
   Range("J1").Value = "HW/SW"
   
   'Transfer the contents of the array to a worksheet range, starting at D2
   Range("G2").Resize(UBound(sData), 2).Value = sData
   
End Sub

 

[Rohith1324]

Try it like this instead

Sub Rohith()
   Dim oDict As Object
   Dim sData() As Variant
   Dim LastRow As Long
   Dim i As Variant
   Dim Cnt As Variant
  
   Set oDict = CreateObject("Scripting.Dictionary")
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   ReDim sData(1 To LastRow, 1 To 2)
   For i = 2 To LastRow
      If Not oDict.Exists(Cells(i, "A").Value) Then
         Cnt = Cnt + 1
         sData(Cnt, 1) = Cells(i, "A").Value
         sData(Cnt, 2) = Cells(i, "B").Value
         oDict.Add Cells(i, "A").Value, Cnt
      Else
         sData(oDict.Item(Cells(i, "A").Value), 2) = _
         sData(oDict.Item(Cells(i, "A").Value), 2) & _
         ", " & Cells(i, "B").Value
      End If
   Next i
  
   Range("G1").Value = Range("A1").Value
   Range("H1").Value = Range("B1").Value
   Range("I1").Value = "Circle"
   Range("J1").Value = "HW/SW"
  
   'Transfer the contents of the array to a worksheet range, starting at D2
   Range("G2").Resize(UBound(sData), 2).Value = sData
  
End Sub

Sure will try and keep you posted...but I have one more question....the previous script I was able to handle even the big data in my system but when I try it on with someone else system it is throwing error.

 

[Fluff]

That depends on what the error was.
It may have been a Compile Error, if they did not have the correct references set, or it may have been down to the data if it was a runtime error.

 

[Rohith1324]

T

Try it like this instead

Sub Rohith()
   Dim oDict As Object
   Dim sData() As Variant
   Dim LastRow As Long
   Dim i As Variant
   Dim Cnt As Variant
  
   Set oDict = CreateObject("Scripting.Dictionary")
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   ReDim sData(1 To LastRow, 1 To 2)
   For i = 2 To LastRow
      If Not oDict.Exists(Cells(i, "A").Value) Then
         Cnt = Cnt + 1
         sData(Cnt, 1) = Cells(i, "A").Value
         sData(Cnt, 2) = Cells(i, "B").Value
         oDict.Add Cells(i, "A").Value, Cnt
      Else
         sData(oDict.Item(Cells(i, "A").Value), 2) = _
         sData(oDict.Item(Cells(i, "A").Value), 2) & _
         ", " & Cells(i, "B").Value
      End If
   Next i
  
   Range("G1").Value = Range("A1").Value
   Range("H1").Value = Range("B1").Value
   Range("I1").Value = "Circle"
   Range("J1").Value = "HW/SW"
  
   'Transfer the contents of the array to a worksheet range, starting at D2
   Range("G2").Resize(UBound(sData), 2).Value = sData
  
End Sub

Thank you so much this is working fine now....

 

[Fluff]

Glad it sorted & thanks for the feedback