Query for Macro
 

Each unique Entries and their corresponding values should get concatenate with uniqueness,Attached macro working correctly but not efficient,I need some suggestion to avoid the Multiple if checks and , Is it possible to create dictionary objects with loops. I want to automate this too.


Sub Working_With_Dic()

Application.ScreenUpdating = False

Set Dc = CreateObject("Scripting.dictionary")
Set Dc1 = CreateObject("Scripting.dictionary")
Set Dc2 = CreateObject("Scripting.dictionary")
Set Dc3 = CreateObject("Scripting.dictionary")

Dc.RemoveAll
Dc1.RemoveAll
Dc2.RemoveAll
Dc3.RemoveAll


For i = 1 To 1085
If Not Dc.Exists(Cells(i, 1).Value) Then
Dc.Add Cells(i, 1).Value, Cells(i, 2).Value
Dc1.Add Cells(i, 1).Value, Cells(i, 3).Value
Dc2.Add Cells(i, 1).Value, Cells(i, 4).Value
Dc3.Add Cells(i, 1).Value, Cells(i, 5).Value

Else
If InStr(1, Dc.Item(Cells(i, 1).Value), Cells(i, 2).Value, vbBinaryCompare) = 0 Then
Dc.Item(Cells(i, 1).Value) = Dc.Item(Cells(i, 1).Value) & "+" & Cells(i, 2).Value
End If

If InStr(1, Dc1.Item(Cells(i, 1).Value), Cells(i, 3).Value, vbBinaryCompare) = 0 Then
Dc1.Item(Cells(i, 1).Value) = Dc1.Item(Cells(i, 1).Value) & "+" & Cells(i, 3).Value
End If

If InStr(1, Dc2.Item(Cells(i, 1).Value), Cells(i, 4).Value, vbBinaryCompare) = 0 Then
Dc2.Item(Cells(i, 1).Value) = Dc2.Item(Cells(i, 1).Value) & "+" & Cells(i, 4).Value
End If

If InStr(1, Dc3.Item(Cells(i, 1).Value), Cells(i, 5).Value, vbBinaryCompare) = 0 Then
Dc3.Item(Cells(i, 1).Value) = Dc.Item(Cells(i, 1).Value) & "+" & Cells(i, 5).Value
End If

End If
Next

i = 1
For Each k In Dc.keys
With Sheets("Sheet2")
.Cells(i, 1) = k
.Cells(i, 2) = Dc.Item(k)
.Cells(i, 3) = Dc1.Item(k)
.Cells(i, 4) = Dc2.Item(k)
.Cells(i, 5) = Dc3.Item(k)
End With
i = i + 1
Next
End Sub

Query for Macro
 

Hi Mandeep,

Am Thu, 3 Dec 2015 03:35:34 -0800 (PST) schrieb Mandeep Baluja:

Each unique Entries and their corresponding values should get concatenate with uniqueness,Attached macro working correctly but not efficient,I need some suggestion to avoid the Multiple if checks and , Is it possible to create dictionary objects with loops. I want to automate this too.

why don't you create a key over the 4 columns?

Try:

Sub Test()
Dim varData As Variant, varOut() As Variant
Dim i As Long, j As Long
Dim myDic As Object
Dim key As String, myStr As String

With Sheets("Sheet1")
If myDic Is Nothing Then
Set myDic = CreateObject("Scripting.Dictionary")
varData = .Range("A1:D1085")
For i = LBound(varData) To UBound(varData)
key = varData(i, 1) & "," & varData(i, 2) & "," _
& varData(i, 3) & "," & varData(i, 4)
If Not myDic.Exists(key) Then
myDic(key) = i
ReDim Preserve varOut(j)
varOut(j) = key
j = j + 1
End If
Next
End If
End With

With Sheets("Sheet2")
For i = LBound(varOut) To UBound(varOut)
.Cells(i + 1, 1).Resize(1, 4) = Split(varOut(i), ",")
Next
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Query for Macro
 

Hi Claush,

My scenario is different what i want is output like this which remove duplicacy,Given below 1 is unique now col2 contains duplicates corresponding to 1 value and col4 contains like same

Data should be like many rows :-
Col1 col2 col3 col4
1 a T C
1 b u c
1 c v c
1 a w c

So output should be like :-
Col1 col2 col3 col4
1 a,b,c T,u,w,w C

Query for Macro
 

Hi Mandeep,

Am Thu, 3 Dec 2015 10:06:00 -0800 (PST) schrieb Mandeep Baluja:

Data should be like many rows :-
Col1 col2 col3 col4
1 a T C
1 b u c
1 c v c
1 a w c

So output should be like :-
Col1 col2 col3 col4
1 a,b,c T,u,w,w C

try:

Sub Test()
Dim varData As Variant, varOut As Variant
Dim LRow As Long, i As Long, j As Long
Dim myDic As Object

With Sheets("Sheet1")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
varData = .Range("A1:D" & LRow)
For j = LBound(varData, 2) To UBound(varData, 2)
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(varData) To UBound(varData)
myDic(varData(i, j)) = varData(i, j)
Next i
varOut = myDic.items
Sheets("Sheet2").Cells(1, j) = Join(varOut, ", ")
Set myDic = Nothing
Next j
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Query for Macro
 

Hi,

Am Thu, 3 Dec 2015 19:43:00 +0100 schrieb Claus Busch:

Set myDic = CreateObject("Scripting.Dictionary")

change the code to:

Sub Test()
Dim varData As Variant, varOut As Variant
Dim LRow As Long, i As Long, j As Long
Dim myDic As Object

With Sheets("Sheet1")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
varData = .Range("A1:D" & LRow)
For j = LBound(varData, 2) To UBound(varData, 2)
Set myDic = CreateObject("Scripting.Dictionary")
myDic.comparemode = vbTextCompare
For i = LBound(varData) To UBound(varData)
myDic(varData(i, j)) = varData(i, j)
Next i
varOut = myDic.items
Sheets("Sheet2").Cells(1, j) = Join(varOut, ", ")
Set myDic = Nothing
Next j
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Query for Macro
 

Not Working, the code i provided to you macro was working perfectly but I just want to remove the Nested ifs because it makes my code to work slow,

While running your code output is coming for the data

1 a c k
1 b d B
1 a e B
1 a f B
1 d g T
2 a c k
2 b d B
2 a e B
2 a f B
2 d g T
2 a c k
2 b d B
2 a e B

Output :-
1, 2 a, b, d c, d, e, f, g k, B, T


But i want is :-
1 b,a,d d,e,f,g B,T k,b,t
2 a,b,d c,d,e,f,g k,B,T

Regards,
Mandeep

Query for Macro
 

Hi Mandeep,

Am Thu, 3 Dec 2015 21:17:04 -0800 (PST) schrieb Mandeep Baluja:

Output :-
1, 2 a, b, d c, d, e, f, g k, B, T

But i want is :-
1 b,a,d d,e,f,g B,T k,b,t
2 a,b,d c,d,e,f,g k,B,T

now I got it ;-)
Try this (a little bit faster than your code):

Sub Test()
Dim varData As Variant, varOut() As Variant
Dim varTmp() As Variant, varTmp2 As Variant
Dim i As Long, j As Long, k As Long, LRow As Long
Dim myDic As Object, myDic2 As Object
Dim key As String, myStr As String

Sheets("Sheet2").UsedRange.ClearContents

With Sheets("Sheet1")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
If myDic Is Nothing Then _
Set myDic = CreateObject("Scripting.Dictionary")
varData = .Range("A1:D" & LRow)
For i = LBound(varData) To UBound(varData)
key = varData(i, 1) & "," & varData(i, 2) & "," _
& varData(i, 3) & "," & varData(i, 4)
If Not myDic.Exists(key) Then
myDic(key) = i
ReDim Preserve varOut(j)
varOut(j) = key
j = j + 1
End If
Next

ReDim Preserve varTmp(UBound(varOut), 3)
For i = LBound(varOut) To UBound(varOut)
For j = 0 To 3
varTmp(i, j) = Split(varOut(i), ",")(j)
Next
Next

If myDic2 Is Nothing Then _
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = LBound(varTmp) To UBound(varTmp)
key = varTmp(i, 0)
If Not myDic2.Exists(key) Then
myDic2(key) = i
End If
Next
varTmp2 = myDic2.keys
Sheets("Sheet2").Range("A1").Resize(UBound(varTmp2 ) + 1) = _
Application.Transpose(varTmp2)

For j = 1 To 3
For k = LBound(varTmp2) To UBound(varTmp2)
For i = LBound(varTmp) To UBound(varTmp)
If varTmp(i, 0) = varTmp2(k) Then
If myStr = "" Then myStr = varTmp(i, j)
If InStr(myStr, varTmp(i, j)) = 0 Then myStr = myStr
& ", " & varTmp(i, j)
End If
Next
Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
myStr = ""
Next
Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
End Sub

Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Query for Macro
 

This is something amazing,Gud work Logic was same but the use of array is brilliantly done !!!

Thanks ,Mandeep

Query for Macro
 

Hi Mandeep,

Am Sun, 6 Dec 2015 23:09:51 -0800 (PST) schrieb Mandeep Baluja:

This is something amazing,Gud work Logic was same but the use of array is brilliantly done !!!
For i = LBound(varData) To UBound(varData)
key = varData(i, 1) & "," & varData(i, 2) & "," _
& varData(i, 3) & "," & varData(i, 4)
If Not myDic.Exists(key) Then
myDic(key) = i
ReDim Preserve varOut(j)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
varOut(j) = key
j = j + 1
End If^

at the position above the array varOut is superfluous.
Try it this way:

Sub Test()
Dim varData As Variant, varOut() As Variant
Dim varTmp() As Variant, varTmp2 As Variant
Dim i As Long, j As Long, k As Long, LRow As Long
Dim myDic As Object, myDic2 As Object
Dim key As String, myStr As String
Dim st As Double
st = Timer

Application.ScreenUpdating = False
Sheets("Sheet2").UsedRange.ClearContents

With Sheets("Sheet1")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
If myDic Is Nothing Then _
Set myDic = CreateObject("Scripting.Dictionary")
varData = .Range("A1:D" & LRow)
For i = LBound(varData) To UBound(varData)
key = varData(i, 1) & "," & varData(i, 2) & "," _
& varData(i, 3) & "," & varData(i, 4)
If Not myDic.Exists(key) Then
myDic(key) = i
End If
Next

varTmp = myDic.keys

ReDim Preserve varOut(UBound(varTmp), 3)
For i = LBound(varTmp) To UBound(varTmp)
For j = 0 To 3
varOut(i, j) = Split(varTmp(i), ",")(j)
Next
Next

If myDic2 Is Nothing Then _
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = LBound(varOut) To UBound(varOut)
key = varOut(i, 0)
If Not myDic2.Exists(key) Then
myDic2(key) = i
End If
Next

varTmp2 = myDic2.keys
Sheets("Sheet2").Range("A1").Resize(UBound(varTmp2 ) + 1) = _
Application.Transpose(varTmp2)

For j = 1 To 3
For k = LBound(varTmp2) To UBound(varTmp2)
For i = LBound(varOut) To UBound(varOut)
If varOut(i, 0) = varTmp2(k) Then
If myStr = "" Then myStr = varOut(i, j)
If InStr(myStr, varOut(i, j)) = 0 Then myStr = myStr
& ", " & varOut(i, j)
End If
Next
Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
myStr = ""
Next
Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
Application.ScreenUpdating = True
MsgBox Format(Timer - st, "0.000")
End Sub



Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional