Actually, for the most part, this is about as efficient as you can get for what
you're trying to do.
You're not going to get away from doing SOME type of IF() test.
the Instr() function is somewhat slow.But in this case, the alternative would
be to create a "unique" key by combining column A and B like "49|RFC-_Allow
Xpressbees_Quick/SDD_Chennai -FC-MAA-Periya-VL-STD"
(or A and C, or A and D) then checking if(dict.exists for each and add.
Then once done, cycle through the keys and split the key string.
You eliminate the Instr() function, but you add an addition "for" loop.
I found an error in your last Instr(). for column E.=dc.item() should be
=dc3.item()
a couple suggestions though, regarding programming "technique".
As you get into larger macros (or this one grows)you'll find it will save you
lots of headaches if you use variables that have "meaning".
For instance: dc1.I suspect d stands for dictionaryand c stands for columnbut
in your case 1 isn't column 1, it's an OFFSET of 1 from the code column.
instead, I'd use Dict_Bor if you're REALLY compulsive, Dict_Name, Dict_FC,
Dict_Method, Dict_Mapped
also, I suggest that you put
Option Explicit
at the top of all modules, and declare all variables.
That way, you don't accidently mistype a variable and allow VBA to define a new
variable.
just as a bit of trivia:Did you ever wonder why loop counters are often i,j,k?
It really goes back to the early (early) days of programming.the "convention"
was that integer variables began with "i".ivalue, icount, inumber
Floating point numbers (1.234, etc.) began with "n":nValue, nCount
String values began with "s":sValue, sName
With some compilers (especially Fortran IV),this was more than "convention", it
was a RULE.
If you used:dim iValue as String
it produced a compiler error.
Other compilers would allow you to NOT manually declare a variable if it
followed the "rules".The first time you used nValue, even if you said nValue =
1it would self-declare it as a floating point number and store 1.0000
So, the simplest integer counter would be "i".
the "j,k" were just because they followed "i" in the alphabet.But the BIGGEST
reason was because all the programming textbooks used i,j,k in their examples.
So, when you were learning to write programs, you got into the habit of using
i,j,k.I often continue to use iValues as integers, but sometimes use nValues as
LONG integers.
letting a little of my OCD kick in, I ended up with this variation of your
macro:
I think I used a loop before to create Userform Objects, but I don't think you
can use a loop to declare variables.
I'll look though.-------------Option ExplicitSub Working_With_Dic()
Dim Dict_B, Dict_C, Dict_D, Dict_E, K
Dim nRows As Long, nRow As Long' Application.ScreenUpdating = False
Set Dict_B = CreateObject("Scripting.dictionary")
Set Dict_C = CreateObject("Scripting.dictionary")
Set Dict_D = CreateObject("Scripting.dictionary")
Set Dict_E = CreateObject("Scripting.dictionary")
Dict_B.RemoveAll
Dict_C.RemoveAll
Dict_D.RemoveAll
Dict_E.RemoveAll
Sheets("Sheet1").Select
Range("A1").Select
nRows = ActiveCell.SpecialCells(xlLastCell).Row '(gets the row number of
the last row of data)
For nRow = 2 To nRows ' 1085? why not all rows? need to skip header (start
at row 2)
If (Cells(nRow, "A").Value & "X" <> "X") Then
If Not Dict_B.Exists(Cells(nRow, "A").Value) Then
Dict_B.Add Cells(nRow, "A").Value, Cells(nRow, "B").Value
Dict_C.Add Cells(nRow, "A").Value, Cells(nRow, "C").Value
Dict_D.Add Cells(nRow, "A").Value, Cells(nRow, "D").Value
Dict_E.Add Cells(nRow, "A").Value, Cells(nRow, "E").Value
Else
If InStr(1, Dict_B.Item(Cells(nRow, "A").Value), Cells(nRow,
"B").Value, vbBinaryCompare) = 0 Then
Dict_B.Item(Cells(nRow, "A").Value) =
Dict_B.Item(Cells(nRow, "A").Value) & "+" & Cells(nRow, "B").Value
End If
If InStr(1, Dict_C.Item(Cells(nRow, "A").Value), Cells(nRow,
"C").Value, vbBinaryCompare) = 0 Then
Dict_C.Item(Cells(nRow, "A").Value) =
Dict_C.Item(Cells(nRow, "A").Value) & "+" & Cells(nRow, "C").Value
End If
If InStr(1, Dict_D.Item(Cells(nRow, "A").Value), Cells(nRow,
"D").Value, vbBinaryCompare) = 0 Then
Dict_D.Item(Cells(nRow, "A").Value) =
Dict_D.Item(Cells(nRow, "A").Value) & "+" & Cells(nRow, "D").Value
End If
If InStr(1, Dict_E.Item(Cells(nRow, "A").Value), Cells(nRow,
"E").Value, vbBinaryCompare) = 0 Then
Dict_E.Item(Cells(nRow, "A").Value) =
Dict_E.Item(Cells(nRow, "A").Value) & "+" & Cells(nRow, "E").Value
' Error with =dc.item instead of =dc3.item
End If
End If
End If
Next
Sheets("Sheet2").Select
Sheets("Sheet2").Range("A2:Z150000").ClearContents
nRow = 1
For Each K In Dict_B.keys
nRow = nRow + 1
With Sheets("Sheet2")
.Cells(nRow, "A") = K
.Cells(nRow, "B") = Dict_B.Item(K)
.Cells(nRow, "C") = Dict_C.Item(K)
.Cells(nRow, "D") = Dict_D.Item(K)
.Cells(nRow, "E") = Dict_E.Item(K)
End With
Next
MsgBox "Finished"
End Sub
Paul-----------------------------------------
“Do all the good you can,
By all the means you can,
In all the ways you can,
In all the places you can,
At all the times you can,
To all the people you can,
As long as ever you can.” - John Wesley
-----------------------------------------
From: Mandeep Baluja <rockerna...@gmail.com>
To: MS EXCEL AND VBA MACROS <excel-macros@googlegroups.com>
Sent: Thursday, December 3, 2015 6:16 AM
Subject: $$Excel-Macros$$ Hey Paul, Need your suggestion
Hey Paul, Need your suggestion
Please check this sheet !!
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.RemoveAllDc1.RemoveAllDc2.RemoveAllDc3.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 IfNext
i = 1For 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 +
1NextEnd Sub
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
