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

S

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:

[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]30004[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]30004[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]59684-1[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]59684-1[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]30898[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]30899[/TD]
[TD]A[/TD]
[/TR]
</tbody>[/TABLE]

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:

[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]30004[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]30004[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]59684-1[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]59684-1[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]85201[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]30899[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]30899[/TD]
[TD]A[/TD]
[/TR]
</tbody>[/TABLE]

Any thoughts? Thanks in advanced for you help!
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
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
MickG said:
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
Click to expand...

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
You must log in or register to reply here.

Similar threads

S
  • Solved
Sequence each duplicate value in multi columns (Scripting Dictionary)
Replies
5
Views
354
Peter_SSs
Peter_SSs
A
  • Solved
Extract duplicates dates and insert TOTAL row for each duplicates dates
Replies
4
Views
106
Alaa mg
A
Q
  • Solved
VBA Macro to Find Missing and Duplicate Data
2 3
Replies
20
Views
1K
kevin9999
K
A
  • Solved
add missed headers for different location based on above rows
Replies
4
Views
200
abdo meghari
A
N
  • Question Question
Color duplicates rows in two different sets of data and also the rows which are present in both sets of data.
Replies
0
Views
459
Noob_Excel
N

Forum statistics

Threads
1,223,239
Messages
6,170,947
Members
452,368
Latest member
jayp2104

Share this page

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