VBA compact attributes in less columns

[bogdant]

Hi everyone. My first post here but used as inspiration many times.

The original data is on A1:F14 and the desired outcome in K1:M14. I`m looking to use less columns to show attributes for each ID on column A. The single restriction is that the unique strings must be placed on the same column, whatever that is.
Does not matter if the outcome is in the same sheet or a new one.

Any idea would be appreciated.
​​​​​​​Thank you!

id

v1

v2

v3

v4

v5

id

v1

v2

1

a

e

1

a

e

2

a

e

2

a

e

3

a

e

3

a

e

4

a

b

4

a

b

5

b

5

b

6

b

d

6

d

b

7

b

d

7

d

b

8

b

d

8

d

b

9

c

d

9

d

c

10

c

10

c

11

c

11

c

12

c

12

c

13

a

13

a

<tbody>
</tbody>

 

[MickG]

Try this:-
You may need to alter the "Rng" address to suit other data !!!
NB:- The position of the original data in "A2:F14") will be altered by the code.

[COLOR="Navy"]Sub[/COLOR] MG14Jun43
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2:F14").SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    [COLOR="Navy"]If[/COLOR] Intersect(Dn, Range("B:C")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] Ac = 2 To 5
            [COLOR="Navy"]If[/COLOR] Application.CountA(Cells(Dn(1).Row, Ac).Resize(Dn.Count)) = 0 [COLOR="Navy"]Then[/COLOR]
                Cells(Dn(1).Row, Ac).Resize(Dn.Count) = Dn.Value
                 Dn.Value = ""
                [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[bogdant]

Mi MickG. It works great!

So I assume will need to change Ac range to reflect the number of columns as well (instead of 5 in this example)?

Thank you!
Bogdan T

 

[MickG]

You're welcome
NB:- When you alter the number of columns in the range "Rng" you will need to reflect the number of columns in the "Ac" loop.
i.e. "B2:F14" = 5 columns

 

[bogdant]

Just applied to some more examples and something goes wrong. I get R5 values both in V1 and V2 and one value of SR3 is copied below the range.
Am I doing something wrong?

Input:

EKV	V1	V2	V3	V4	V5	V6
2			SR3	SR4		SR6
9			SR3		SR5	SR6
21		SR2	SR3	SR4		SR6
112	SR1		SR3		SR5	SR6
115			SR3	SR4		SR6
117			SR3		SR5	SR6
349			SR3		SR5	SR6
352		SR2	SR3	SR4		SR6
1417			SR3		SR5	SR6
1980			SR3		SR5	SR6
2458			SR3			SR6
3558			SR3			SR6
3575			SR3		SR5	SR6
3592			SR3	SR4		SR6

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

Output:

EKV	V1	V2	V3	V4
2	SR4		SR6	SR3
9	SR5		SR6	SR3
21	SR4	SR2	SR6	SR3
112	SR1	SR5	SR6	SR3
115	SR4		SR6	SR3
117	SR5		SR6	SR3
349	SR5		SR6	SR3
352	SR4	SR2	SR6	SR3
1417	SR5		SR6	SR3
1980	SR5		SR6	SR3
2458			SR6	SR3
3558			SR6	SR3
3575	SR5		SR6	SR3
3592	SR3		SR6
	SR3

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

and the code was

Sub MG14Jun43()
Dim Rng As Range, Dn As Range, Ac As Long, col As Range
Set Rng = Range("B2:G15").SpecialCells(xlCellTypeConstants)
For Each Dn In Rng.Areas
If Intersect(Dn, Range("B:C")) Is Nothing Then
For Ac = 2 To 6
If Application.CountA(Cells(Dn(1).Row, Ac).Resize(Dn.Count)) = 0 Then
Cells(Dn(1).Row, Ac).Resize(Dn.Count) = Dn.Value
Dn.Value = ""
Exit For
End If
Next Ac
End If
Next Dn
End Sub

 

[MickG]

Try this:-
If not what you want please show example of expected results.
NB:- This code takes a few seconds to Run.

[COLOR="Navy"]Sub[/COLOR] MG15Jun19
[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] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2:G15")
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
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rw [COLOR="Navy"]In[/COLOR] Dn.Cells
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Rw.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not .Exists(Rw.Value) [COLOR="Navy"]Then[/COLOR]
                 .Add Rw.Value, Rw
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] .Item(Rw.Value) = Union(.Item(Rw.Value), Rw)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Rw
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Range, Fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] Not .Item(K).Column = 2 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] ac = 2 To Rng.Columns.Count
            Fd = False
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] .Item(K)
                [COLOR="Navy"]If[/COLOR] Not IsEmpty(Cells(P.Row, ac)) [COLOR="Navy"]Then[/COLOR]
                    Fd = True: [COLOR="Navy"]Exit[/COLOR] For
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] P
            [COLOR="Navy"]If[/COLOR] Fd = False [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] .Item(K)
                    Cells(P.Row, ac) = P
                    [COLOR="Navy"]If[/COLOR] Not Cells(P.Row, ac).Address = P.Address [COLOR="Navy"]Then[/COLOR] P.Value = ""
                [COLOR="Navy"]Next[/COLOR] P
                [COLOR="Navy"]Exit[/COLOR] For:
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] ac
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[bogdant]

Hi Mick,
this code looks like it takes care of not spreading the same string on multiple columns. The time is ok, my ranges are not that great. I`ll test it more in the following days.

Thank you again for helping with this.

Regards Bogdan T

 

[MickG]

You're welcome