Hi,
I need to uniquify duplicate column headings, but I'm getting lost with the counting aspect (in addition to the fact that I'm using the Scripting.Dictionary which I'm still new too). Please see the two attachments, (1) the workbook with the macro and (2) the workbook to import. In the real sense, the macro will be uniquifying 100's of table headers.
TX for assistance
Increment Duplicates each with 1
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Increment Duplicates each with 1
You do not have the required permissions to view the files attached to this post.
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- 5StarLounger
- Posts: 818
- Joined: 24 Jan 2010, 15:56
Re: Increment Duplicates each with 1
What are you actually trying to do with the unique names? You don't do anything with the dictionary and nor do you save the workbooks, so I can't really tell what the goal is.
Regards,
Rory
Rory
-
- Administrator
- Posts: 78608
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Increment Duplicates each with 1
I'd change the loop to
Note that you had wb.Close False. This would discard any changes you made...
Code: Select all
Do While sFile <> ""
If sFile <> sThisWB Then
Set wb = Workbooks.Open(Filename:=sPath & sFile)
Set sh = wb.Sheets(1)
Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary")
Set rgF = sh.Columns("A").Find(What:="Member Number")
If Not rgF Is Nothing Then
Set rg = sh.Range(rgF, rgF.EntireRow.Cells(1, rgF.EntireRow.Columns.Count).End(xlToLeft))
For Each c In rg.Cells
If dict.exists(c.Value) Then
'Increment each duplicate individually by 1
dict(c.Value) = dict(c.Value) + 1
c.Value = c.Value & dict(c.Value)
Else
dict.Add c.Value, 1
End If
Next c
End If
wb.Close True
Set dict = Nothing
End If
sFile = Dir
Loop
Best wishes,
Hans
Hans
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Increment Duplicates each with 1
Hi Rudi,
I had to google uniquify first as I did not recognise that word. !!
I have been playing around with Dictionaries and other alternatives recently, but I am too a bit unclear as to what you are actually wanting to do.
As Rory commented you are not actually doing anything with your Dictionary as you set it to nothing after filling it.
One I thing I notice.
This line
dict.Add c, i
is adding a Range Object as the Key to the Dictionary. Possibly you want that? But I have seen this as a very common error when actually this was intended.
dict.Add c.value, i
Possibly you meant this:
This is one of those rare occasions when missing the .Value Catches people out. (I will not tell you the names of some people I have previously pointed out this mistake to in just such a code line !! ) Relying on the Inplicitly implied default is mostly not wise.
( _..It is one of the wierd concepts of the MSRD that a Key can be almost anything ( I think only Arrays are not allowed ) . In many cases just keys are used when looking to get unique lists, as there is a very neat one line to do that
http://www.excelforum.com/showthread.ph ... ost4423826" onclick="window.open(this.href);return false;
_..)
Alan
EDIT: looks like Hans picked up the .Value bit as well !
I had to google uniquify first as I did not recognise that word. !!
I have been playing around with Dictionaries and other alternatives recently, but I am too a bit unclear as to what you are actually wanting to do.
As Rory commented you are not actually doing anything with your Dictionary as you set it to nothing after filling it.
One I thing I notice.
This line
dict.Add c, i
is adding a Range Object as the Key to the Dictionary. Possibly you want that? But I have seen this as a very common error when actually this was intended.
dict.Add c.value, i
Possibly you meant this:
Code: Select all
For Each c In rg.Cells
If dict.exists(c.Value) Then
'Increment each duplicate individually by 1
dict.Add c.Value & j, i
j = j + 1
Else
dict.Add c.Value, i
End If
i = i + 1
Next c
( _..It is one of the wierd concepts of the MSRD that a Key can be almost anything ( I think only Arrays are not allowed ) . In many cases just keys are used when looking to get unique lists, as there is a very neat one line to do that
http://www.excelforum.com/showthread.ph ... ost4423826" onclick="window.open(this.href);return false;
_..)
Alan
EDIT: looks like Hans picked up the .Value bit as well !
Last edited by Doc.AElstein on 24 Oct 2016, 21:55, edited 1 time in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- Administrator
- Posts: 78608
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Increment Duplicates each with 1
Please note that I use the words as originally present in the row as keys of the dictionary items, and the number of times a word has been encountered as the value of the items.
So the first time a word is encountered, we create an item with the word as key and 1 as value.
Each time we encounter the same word after that, we add 1 to the value of the item, and set the cell to the original contents (the word) followed by the value of its dictionary item (the counter).
I don't use Rudi's variables i and j at all.
So the first time a word is encountered, we create an item with the word as key and 1 as value.
Each time we encounter the same word after that, we add 1 to the value of the item, and set the cell to the original contents (the word) followed by the value of its dictionary item (the counter).
I don't use Rudi's variables i and j at all.
Best wishes,
Hans
Hans
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Increment Duplicates each with 1
Hi Hans
I too do not use any long count variables
The first time I encounter a heading, an element is added to the Dictionary. Its Key is the heading value. Its item is given the value of 1
If the heading is encountered again, then first I increase the item value for that heading by 1
An Element is then added to the Dictionary. Its Key is the heading value concatenated with the Item of that heading. (Its item can be given anything. I only use the Item for the first ( unique ) heading )
So the item for each unique heading gives the count so far for that heading occurrence. Concatanating that with the heading for any duplicate headings will give the required " Increment Duplicates each with 1 "
Demo Code:
This code:
_.. takes this in Rudi’s uploaded sample data file, TestImport.xlsx, :
Using Excel 2007 32 bit
|< < > >|_Source_/___//
_and returns this :
Using Excel 2007 32 bit
|< < > >|_Source_/___//
_.....
Alan
Yes , I guessed what Rudi wanted from his sample data File, and I was trying to do something very similar to you. It just took me a lot longer !!HansV wrote:Please note that I use the words as originally present in the row as keys of the dictionary items, and the number of times a word has been encountered as the value of the items.....
I too do not use any long count variables
The first time I encounter a heading, an element is added to the Dictionary. Its Key is the heading value. Its item is given the value of 1
If the heading is encountered again, then first I increase the item value for that heading by 1
An Element is then added to the Dictionary. Its Key is the heading value concatenated with the Item of that heading. (Its item can be given anything. I only use the Item for the first ( unique ) heading )
So the item for each unique heading gives the count so far for that heading occurrence. Concatanating that with the heading for any duplicate headings will give the required " Increment Duplicates each with 1 "
Demo Code:
This code:
Code: Select all
Option Explicit
Sub MakeUniqueHeaders()
Dim wb As Workbook, sh As Worksheet, sPath As String, sFile As String, sExt As String, dFolder As FileDialog, rgF As Range, rg As Range, sThisWB As String, dict As Variant, c As Variant
On Error GoTo ErrorH
Let Application.ScreenUpdating = False
Let Application.EnableEvents = False
Let Application.DisplayAlerts = False
Let sThisWB = ThisWorkbook.Name
For Each sh In ThisWorkbook.Sheets
If sh.Name <> "Macro" Then sh.Delete
Next sh
Set dFolder = Application.FileDialog(msoFileDialogFolderPicker)
With dFolder
.Title = "Select Target Folder Containing Source Files"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
Let sPath = .SelectedItems(1) & "\"
End With
Let sExt = "*.xls*"
Let sFile = Dir(sPath & sExt)
Do While sFile <> ""
If sFile <> sThisWB Then
Set wb = Workbooks.Open(Filename:=sPath & sFile)
Set sh = wb.Sheets(1)
'Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary")
Set rgF = sh.Columns("A").Find(What:="Member Number")
If Not rgF Is Nothing Then
Set rg = sh.Range(rgF, rgF.EntireRow.Cells(1, rgF.EntireRow.Columns.Count).End(xlToLeft))
For Each c In rg.Cells
If dict.exists(c.Value) Then ' If the heading is encountered again, then first I increase the item value for that heading by 1If the heading is encountered again, then first I increase the item value for that heading by 1
Let dict.Item(c.Value) = dict.Item(c.Value) + 1 '
dict.Add Key:=c.Value & dict.Item(c.Value), Item:="AnyFink"
Else 'The first time I encounter a heading, an element is added to the Dictionary. Its Key is the heading value. Its item is given the value of 1
dict.Add Key:=c.Value, Item:=1
End If
Next c
'Do Stuff demo
Dim arrkeys() As Variant ' .Keys() property returns a field of Variant type Elements
Let arrkeys() = dict.keys()
Let rg.Offset(1, 0).Value = arrkeys()
End If
wb.Close True
Set dict = Nothing
End If
Let sFile = Dir
Loop
MsgBox "Completed processing each workbook in folder: " & vbNewLine & sPath, vbInformation
ExitH:
Let Application.DisplayAlerts = True
Let Application.EnableEvents = True
Let Application.ScreenUpdating = True
Exit Sub
ErrorH: 'Error handling code section
MsgBox Err.Description, vbExclamation
Resume ExitH
End Sub
Using Excel 2007 32 bit
Row\Col | A | B | C | D | E | F | G | H | I | J | K | L |
5 | Member Number | Age | ID | Test | Result | Eval | Test | Result | Check | Score | Test | Score |
_and returns this :
Using Excel 2007 32 bit
Row\Col | A | B | C | D | E | F | G | H | I | J | K | L |
5 | Member Number | Age | ID | Test | Result | Eval | Test | Result | Check | Score | Test | Score |
6 | Member Number | Age | ID | Test | Result | Eval | Test2 | Result2 | Check | Score | Test3 | Score2 |
_.....
Alan
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 24 Oct 2016, 16:31, edited 1 time in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: Increment Duplicates each with 1
Hi Rory,rory wrote:What are you actually trying to do with the unique names? You don't do anything with the dictionary and nor do you save the workbooks, so I can't really tell what the goal is.
TX for the response.
I'm not sure if you noticed and I admit that I forgot to indicate it in my post, but I did set up a "before" and "after" for comparison in the macro workbook I uploaded. I hoped that would have clarified what my intentions were for the code. Sorry if it was unclear.
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: Increment Duplicates each with 1
Alan;
I think "uniquify" is my own word? LOL! I was in a rush to go to a meeting and wanted to get my post out before I left. It was the first thing that came to mind that described that I needed to produce unique headers and each time they repeated that I needed it incremented by one here each unique title. I think I'll hold on to it and even patent it
Thanks for your code ad the usual commentary. It helps to clear up this (IMHO) very valuable addition to VBA (I prefer it to collections because its more flexible). The problem is I don't use it as often as I like and forget the details of it. You code works well. I appreciate your time and effort and detailed response.
I think "uniquify" is my own word? LOL! I was in a rush to go to a meeting and wanted to get my post out before I left. It was the first thing that came to mind that described that I needed to produce unique headers and each time they repeated that I needed it incremented by one here each unique title. I think I'll hold on to it and even patent it
Thanks for your code ad the usual commentary. It helps to clear up this (IMHO) very valuable addition to VBA (I prefer it to collections because its more flexible). The problem is I don't use it as often as I like and forget the details of it. You code works well. I appreciate your time and effort and detailed response.
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: Increment Duplicates each with 1
Hans;
Thanks for the code too. As usual it works first time round too.
Much appreciated.
PS: I was aware of the wb.Close False > I was in testing phase at the time and didn't want to save the results.
Thanks for the code too. As usual it works first time round too.
Much appreciated.
PS: I was aware of the wb.Close False > I was in testing phase at the time and didn't want to save the results.
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Increment Duplicates each with 1
Hi Rudi,
I took the interest as just recently I have been getting quite into MSRD stuff and the collection, ArrayList alternatives.
I look a lot here recently, - snb is pretty thorough with his list stuff and has added collections and ArrayLists just recently.
http://www.snb-vba.eu/VBA_Arraylist_en.html" onclick="window.open(this.href);return false;
http://www.snb-vba.eu/VBA_Collection_en.html" onclick="window.open(this.href);return false;
http://www.snb-vba.eu/VBA_Dictionary_en.html" onclick="window.open(this.href);return false;
_..................
Your requirement is one where both the Keys and Items are used effectively in a code. When using the MSRD for playing around with Unique stuff, or getting thereof, most often only the keys are used, as a neat one liner can be used to get a unique list.
This is because if you try to get an item through its key when that key does not exist,
then that Key is made. ( So an element is added to the Dictionary. Its item stays at Nothing )
If you try that again and so that key does exist now then the key is not made. ( You get Nothing back as there is still nothing held as an item for that key ) You can use any simple variable I think to take that "Nothing", which probably means it is not really Nothing, but may be rather nothing
So you loop through all things you want a unique List of and just try to get an item through its key, where the Key is each time the next thing in the List you want to get a Unique list of. (Rem Loopy DiK in my code below )
In your case if you do use this method, then you would need a nested Loop or similar code section to do the stuff you want. So you have probably lost the advantages of the quick getting unique method. ( You cannot even use an Exit For once you have found something as you must look a t all in this Arrray Sort Of Sort where ypur final Output is the same list a bit altrered in values
http://www.excelfox.com/forum/showthrea ... 5#post9985" onclick="window.open(this.href);return false; )
So the Key and Item idea really is useful in such a code. You could do the whole thing with Arrays, and I did a load of stuff like that, re inventig the Wheel and developed my own Functions that do all the MSRD does... about 100 posts starting from about here I think
http://www.excelforum.com/showthread.ph ... ost4422820" onclick="window.open(this.href);return false;
_.... but i wish i had not,... as you say the use of the external library, Microsoft Scripting Runtime, is very handy and efficient when sorting and mucking about with lists. Without it Re Diming Arrays and the such can get really messy..
_.....................
I did a Code version using keys only to get a unique list:
( It looks less cluttered in the VB Editor code window ) or here:
http://www.excelforum.com/showthread.ph ... ost4508078" onclick="window.open(this.href);return false;
( It gives the same results as my first version of your code )
Alan
EDIT: I always forget this bit... You can at least in my last code do away with my making of an Array for the Keys, arrKeys(), by referencing diractly a key by its index number ( staring at 0 ) like
= dict.keys()(index)
I cannot complain about that, I make up obscure words to match my even more obscure theories all the time. :) ;)Rudi wrote:Alan;
I think "uniquify" is my own word? LOL! I..... I think I'll hold on to it and even patent it ...
I took the interest as just recently I have been getting quite into MSRD stuff and the collection, ArrayList alternatives.
I look a lot here recently, - snb is pretty thorough with his list stuff and has added collections and ArrayLists just recently.
http://www.snb-vba.eu/VBA_Arraylist_en.html" onclick="window.open(this.href);return false;
http://www.snb-vba.eu/VBA_Collection_en.html" onclick="window.open(this.href);return false;
http://www.snb-vba.eu/VBA_Dictionary_en.html" onclick="window.open(this.href);return false;
_..................
Your requirement is one where both the Keys and Items are used effectively in a code. When using the MSRD for playing around with Unique stuff, or getting thereof, most often only the keys are used, as a neat one liner can be used to get a unique list.
This is because if you try to get an item through its key when that key does not exist,
then that Key is made. ( So an element is added to the Dictionary. Its item stays at Nothing )
If you try that again and so that key does exist now then the key is not made. ( You get Nothing back as there is still nothing held as an item for that key ) You can use any simple variable I think to take that "Nothing", which probably means it is not really Nothing, but may be rather nothing
So you loop through all things you want a unique List of and just try to get an item through its key, where the Key is each time the next thing in the List you want to get a Unique list of. (Rem Loopy DiK in my code below )
In your case if you do use this method, then you would need a nested Loop or similar code section to do the stuff you want. So you have probably lost the advantages of the quick getting unique method. ( You cannot even use an Exit For once you have found something as you must look a t all in this Arrray Sort Of Sort where ypur final Output is the same list a bit altrered in values
http://www.excelfox.com/forum/showthrea ... 5#post9985" onclick="window.open(this.href);return false; )
So the Key and Item idea really is useful in such a code. You could do the whole thing with Arrays, and I did a load of stuff like that, re inventig the Wheel and developed my own Functions that do all the MSRD does... about 100 posts starting from about here I think
http://www.excelforum.com/showthread.ph ... ost4422820" onclick="window.open(this.href);return false;
_.... but i wish i had not,... as you say the use of the external library, Microsoft Scripting Runtime, is very handy and efficient when sorting and mucking about with lists. Without it Re Diming Arrays and the such can get really messy..
_.....................
I did a Code version using keys only to get a unique list:
( It looks less cluttered in the VB Editor code window ) or here:
http://www.excelforum.com/showthread.ph ... ost4508078" onclick="window.open(this.href);return false;
( It gives the same results as my first version of your code )
Code: Select all
Sub MakeUniqueHeadersKeysOnly()
Dim wb As Workbook, sh As Worksheet, sPath As String, sFile As String, sExt As String, dFolder As FileDialog, rgF As Range, rg As Range, sThisWB As String, dict As Variant, c As Variant
On Error GoTo ErrorH
Let Application.ScreenUpdating = False
Let Application.EnableEvents = False
Let Application.DisplayAlerts = False
Let sThisWB = ThisWorkbook.Name
For Each sh In ThisWorkbook.Sheets
If sh.Name <> "Macro" Then sh.Delete
Next sh
Set dFolder = Application.FileDialog(msoFileDialogFolderPicker)
With dFolder
.Title = "Select Target Folder Containing Source Files"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
Let sPath = .SelectedItems(1) & "\"
End With
Let sExt = "*.xls*"
Let sFile = Dir(sPath & sExt)
Do While sFile <> ""
If sFile <> sThisWB Then
Set wb = Workbooks.Open(Filename:=sPath & sFile)
Set sh = wb.Sheets(1)
'Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary") 'Late Binding MSRD
Set rgF = sh.Columns("A").Find(What:="Member Number")
If Not rgF Is Nothing Then
Set rg = sh.Range(rgF, rgF.EntireRow.Cells(1, rgF.EntireRow.Columns.Count).End(xlToLeft))
Dim rgV() As Variant: Let rgV() = rg.Value
Dim myLong As Long 'Anything will do, choose a simple variable
Rem Loopy DiK
Dim Cnt As Long
For Cnt = 1 To UBound(rgV(), 2)
Let myLong = dict.Item(rgV(1, Cnt)) 'it is a by product of the MSRD that if no Key exists , then one will be made by an attempt to an item by that key
Next Cnt
Dim arrkeys() As Variant ' .Keys() property returns a field of Variant type Elements
Let arrkeys() = dict.keys()
'Do Stuff demo
Dim UnCnt As Long, CntHed 'Loop Bound variable Count for Unique Headings, count for a heading occurance
Let CntHed = 0
For UnCnt = 1 To dict.Count ' going For each unique Heading and at each ...
For Cnt = 1 To UBound(rgV(), 2) ' ... go througth see if we find that heading and ...
If rgV(1, Cnt) = arrkeys(UnCnt - 1) Then
Let CntHed = CntHed + 1 'Make the count of this heading 1 2 or 3 o r 4 etc...
If CntHed <> 1 Then ' see if we are at second or more occurance of that heading
Let rgV(1, Cnt) = rgV(1, Cnt) & CntHed ' ... concatenate this occurrance of the heading with a number equal to its occurrance number
Else 'We are at the first occurance of the heading so do nothing
End If
Else ' we are not at a heading match to the unique heading being looked for so do nothing: Redundant code
End If
Next Cnt
Let CntHed = 0 ' reset for next unique Heading
Next UnCnt
Let rg.Offset(1, 0).Value = rgV()
End If ' end of If Not rgF Is Nothing Then
wb.Close True
Set dict = Nothing
End If
Let sFile = Dir
Loop
MsgBox "Completed processing each workbook in folder: " & vbNewLine & sPath, vbInformation
ExitH:
Let Application.DisplayAlerts = True
Let Application.EnableEvents = True
Let Application.ScreenUpdating = True
Exit Sub
ErrorH: 'Error handling code section
MsgBox Err.Description, vbExclamation
Resume ExitH
End Sub
Alan
EDIT: I always forget this bit... You can at least in my last code do away with my making of an Array for the Keys, arrKeys(), by referencing diractly a key by its index number ( staring at 0 ) like
= dict.keys()(index)
Code: Select all
' Dim arrkeys() As Variant ' .Keys() property returns a field of Variant type Elements
' Let arrkeys() = dict.keys()
'Do Stuff demo
Dim UnCnt As Long, CntHed 'Loop Bound variable Count for Unique Headings, count for a heading occurance
Let CntHed = 0
For UnCnt = 1 To dict.Count ' going For each unique Heading and at each ...
For Cnt = 1 To UBound(rgV(), 2) ' ... go througth see if we find that heading and ...
'If rgV(1, Cnt) = arrkeys(UnCnt - 1) Then
If rgV(1, Cnt) = dict.keys()(UnCnt - 1) Then
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: Increment Duplicates each with 1
TX Alan. Gotcha.
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.