[COLOR="Navy"]Sub[/COLOR] MG22May26
[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
[COLOR="Navy"]Set[/COLOR] 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]