VBA Fill missing information

[notrealname]

Hi,
Searching for help to automatically fill missing information in column E where cells in column D match:

Control Number	Control
50071879
50071879
50071879
50071879	Critical Spares for Girth Gear
50071879
50071879
50071879
50071878
50071878
50071878
50071878
50071878	Perform maintenance tasks to detect misalignment and deficient grease
50071878
50071878

<colgroup><col><col></colgroup><tbody>
</tbody>

 

[mole999]

if you created a table of number and control on a separate sheet, then you could use vba to run down the list where missing and insert the relevant information on blanks

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG03Apr50
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & 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, Array(Dn, Dn.Offset(, 1).Value)
[COLOR="Navy"]Else[/COLOR]
    Q = .Item(Dn.Value)
        [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
        Q(1) = Q(1) & Dn.Offset(, 1).Value
    .Item(Dn.Value) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    .Item(K)(0).Offset(, 1).Value = Trim(.Item(K)(1))
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[notrealname]

Returns Compile error: Expected End With

 

[Michael M]

MickG appears to be offline, but try

Sub MG03Apr50()
Dim Rng As Range, Dn As Range, n As Long, Q As Variant
Set Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
   .Add Dn.Value, Array(Dn, Dn.Offset(, 1).Value)
Else
    Q = .Item(Dn.Value)
        Set Q(0) = Union(Q(0), Dn)
        Q(1) = Q(1) & Dn.Offset(, 1).Value
    .Item(Dn.Value) = Q
End If
Next
Dim K As Variant
For Each K In .keys
    .Item(K)(0).Offset(, 1).Value = Trim(.Item(K)(1))
Next K
[color=red]End With[/color]
End Sub

 

[MickG]

Thanks Michael !!
I've made that copying error once or twice lately. I think a slight rethink is required !!!
Regrds Mick