VBA Fill missing information

[notrealname]

Hi,
Searching for help to automatically fill missing information in column E where cells in column D match:
[TABLE="width: 557"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Control Number[/TD]
[TD]Control[/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD]Critical Spares for Girth Gear [/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071879[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD]Perform maintenance tasks to detect misalignment and deficient grease[/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]50071878[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[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