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

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
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
 
Upvote 0
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)
 
Upvote 0
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
 
Upvote 0
I removed the ones with UA and A1 etc, I can do those manually.

After doing that, it works perfectly! Thanks so much
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,988
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top