Increment Duplicates each with 1

[Rudi]

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

Create Primary PQ Table.xlsm

TestImport.xlsx

[rory]

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.

[HansV]

I'd change the loop to

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

Note that you had wb.Close False. This would discard any changes you made...

[Doc.AElstein]

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:

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

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 !

[HansV]

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.

[Doc.AElstein]

Hi Hans

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.....

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 !!

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

_.. takes this in Rudi’s uploaded sample data file, TestImport.xlsx, :
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

|< < > >|_Source_/___//

_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

|< < > >|_Source_/___//

_.....

Alan

[Rudi]

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.

Hi Rory,

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.

[Rudi]

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.

[Rudi]

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.

[Doc.AElstein]

Hi Rudi,

Alan;
I think "uniquify" is my own word? LOL! I..... I think I'll hold on to it and even patent it ...

I cannot complain about that, I make up obscure words to match my even more obscure theories all the time. :) ;)
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

[Rudi]

TX Alan. Gotcha.