Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro Query | Excel Discussion (Misc queries) | |||
Web query: Want to pause macro while Web query completes refreshin | Excel Programming | |||
another macro query - deleting a worksheet within a query | Excel Discussion (Misc queries) | |||
Macro Query | Excel Programming | |||
Query Macro | Excel Programming |