Run a VBA code to remove blank cells and return first non-blank cell with multiple criterias

[gracecyl]

Hi, I require a VBA code to help me remove blank cells across different column labels to reflect the first non-blank cell in each column across unique row labels.

This:

Has to end up looking like:

Where all the duplicated row labels are removed, with only unique values remaining and the results reflected in a single row.

PLEASE HELP!!!

Thank you very much.

 

[MickG]

Try this:-

[COLOR=navy]Sub[/COLOR] MG21May03
[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] Ac [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
Set Rng = ActiveSheet.Cells(1).CurrentRegion
Application.ScreenUpdating = False
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Columns(1).Cells
     [COLOR=navy]If[/COLOR] Dn.Row > 1 [COLOR=navy]Then[/COLOR]
         [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
                .Add Dn.Value, Dn
         [COLOR=navy]Else[/COLOR]
                [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] nRng = Dn Else [COLOR=navy]Set[/COLOR] nRng = Union(nRng, Dn)
         [COLOR=navy]End[/COLOR] If
      
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Ac [COLOR=navy]In[/COLOR] Rng.Rows(Dn.Row).Cells
            [COLOR=navy]If[/COLOR] Not Ac.Column = 1 [COLOR=navy]Then[/COLOR]
                [COLOR=navy]If[/COLOR] Not IsEmpty(Ac) [COLOR=navy]Then[/COLOR]
                    Cells(.Item(Dn.Value).Row, Ac.Column) = Ac
                [COLOR=navy]End[/COLOR] If
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] Ac
    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With
[COLOR=navy]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] nRng.EntireRow.Delete
Application.ScreenUpdating = True
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[gracecyl]

Thank you Micki! This worked perfectly!

 

[MickG]

You're welcome