*Difficult Macro Request* Add rows for missing letter series for each set of duplicates

smreinholtz

New Member
Joined
Jul 10, 2014
Messages
11
Hello,

I have a macro request that may be difficult but I hope you are up for the challenge :)

I have a group of data that looks like this:

30004A
30004B
59684-1B
59684-1C
85201A
85201C
85201D
85201E
30898A
30899A

<tbody>
</tbody>

As you can see, I the first column contains material numbers, while the second contains revision letters. What I need to do create a new row for each missing letter, stopping at the end of the material number group. So this previous data would become:

30004A
30004B
A
59684-1B
59684-1C
85201A
B
85201C
85201D
85201E
30899A
30899A

<tbody>
</tbody>

Any thoughts? Thanks in advanced for you help!
 

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Your data columns "A/B"
Results columns "F/G"
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Aug55
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] G               [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
  n = 65
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] .Item(K)
     [COLOR="Navy"]Do[/COLOR] Until G = Chr(n)
        c = c + 1
        Cells(c, "G") = Chr(n)
        n = n + 1
      [COLOR="Navy"]Loop[/COLOR]
        n = n + 1
        c = c + 1
        Cells(c, "F") = K: Cells(c, "G") = G
  [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

smreinholtz

New Member
Joined
Jul 10, 2014
Messages
11
Try this:-
Your data columns "A/B"
Results columns "F/G"
Code:
[COLOR=Navy]Sub[/COLOR] MG05Aug55
[COLOR=Navy]Dim[/COLOR] Rng             [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dn              [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] n               [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] K               [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] G               [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] c               [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        .Add Dn.Value, Dn.Offset(, 1)
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]


[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] .keys
  n = 65
  [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] G [COLOR=Navy]In[/COLOR] .Item(K)
     [COLOR=Navy]Do[/COLOR] Until G = Chr(n)
        c = c + 1
        Cells(c, "G") = Chr(n)
        n = n + 1
      [COLOR=Navy]Loop[/COLOR]
        n = n + 1
        c = c + 1
        Cells(c, "F") = K: Cells(c, "G") = G
  [COLOR=Navy]Next[/COLOR] G
[COLOR=Navy]Next[/COLOR] K
[COLOR=Navy]End[/COLOR] With


[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
This appears to work for about half the spreadsheet, then I get gibberish with strange characters. The macro gives me "Run-time error '5': Invalid procedure call or argument"

When I hit debug it highlights this line of code: Do Until G = Chr(n)
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
I would need the data it failed on to amend the code !!!!
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
There are some inconsistencies in your data.
When you get to "Z" you start "AA", I have accounted for that in the code below, but you also have column "B" values like "C1",A1", which the code also rides over, but you also Have a duplicate 3096 ===A, which the code errors at.
If you remove that duplicate the code should work Ok, When you've done that and tried the new code. Let me know what you want to do about the duplicates or anything else.
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Aug33
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] G               [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
  n = 65
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] .Item(K)
     [COLOR="Navy"]If[/COLOR] Len(G) > 1 [COLOR="Navy"]Then[/COLOR]
        Temp = Left(G, Len(G) - 1)
        n = 65
     [COLOR="Navy"]Else[/COLOR]
        Temp = Right(G, 1)
     [COLOR="Navy"]End[/COLOR] If
     
     [COLOR="Navy"]Do[/COLOR] Until Temp = Chr(n)
        c = c + 1
        Cells(c, "G") = IIf(Len(Temp) > 1, Temp & Chr(n), Chr(n))
        t = IIf(Len(Temp) > 1, Temp & Chr(n), Chr(n))


        n = n + 1
      [COLOR="Navy"]Loop[/COLOR]
        n = n + 1
        c = c + 1
        Cells(c, "F") = K: Cells(c, "G") = G
  [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
MsgBox "End"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

smreinholtz

New Member
Joined
Jul 10, 2014
Messages
11
I removed the ones with UA and A1 etc, I can do those manually.

After doing that, it works perfectly! Thanks so much
 

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
23,254
You might use this
Code:
Sub test()
    Dim workingCell As Range, checkNumber As Variant
    Dim workLetterCode As Long, workLetterAbove As Long
    Set workingCell = Sheet1.Range("B65536").End(xlUp)
    
    checkNumber = CStr(workingCell.Offset(0, -1).Value)
    
    Do
        With workingCell
            workLetterCode = Asc(UCase(Chr(Asc(CStr(.Value)))))
            workLetterAbove = Asc(UCase(Chr(Asc(CStr(.Offset(-1, 0).Value)))))
        End With
        
        If workLetterCode = 65 Then
            checkNumber = CStr(workingCell.Offset(-1, -1).Value)
        Else
            If checkNumber = CStr(workingCell.Offset(-1, -1).Value) Then
                If workLetterAbove <> workLetterCode - 1 Then GoSub InsertRow
            Else
                GoSub InsertRow
            End If
        End If
    
        Set workingCell = workingCell.Offset(-1, 0)
    Loop Until workingCell.Row = 1
    Exit Sub
InsertRow:
    With workingCell
        .EntireRow.Insert
        .Offset(-1, 0).Value = Chr(workLetterCode - 1)
    End With
    Return
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,095,362
Messages
5,444,022
Members
405,260
Latest member
Khauff

This Week's Hot Topics

Top