VBA compact attributes in less columns

B

bogdant

New Member
Joined
Jun 14, 2018
Messages
4
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!

[TABLE="width: 832"]
<tbody>[TR]
[TD="width: 64"]id[/TD]
[TD="width: 64"]v1[/TD]
[TD="width: 64"]v2[/TD]
[TD="width: 64"]v3[/TD]
[TD="width: 64"]v4[/TD]
[TD="width: 64"]v5[/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"]id[/TD]
[TD="width: 64"]v1[/TD]
[TD="width: 64"]v2[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]a[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]e[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD]a[/TD]
[TD]e[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD]a[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]e[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]2[/TD]
[TD]a[/TD]
[TD]e[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD]a[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]e[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]3[/TD]
[TD]a[/TD]
[TD]e[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD]a[/TD]
[TD]b[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]4[/TD]
[TD]a[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD][/TD]
[TD]b[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]5[/TD]
[TD][/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD][/TD]
[TD]b[/TD]
[TD][/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]6[/TD]
[TD]d[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD][/TD]
[TD]b[/TD]
[TD][/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]7[/TD]
[TD]d[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[TD][/TD]
[TD]b[/TD]
[TD][/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]8[/TD]
[TD]d[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD][/TD]
[TD][/TD]
[TD]c[/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]9[/TD]
[TD]d[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD][/TD]
[TD][/TD]
[TD]c[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]10[/TD]
[TD][/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD][/TD]
[TD][/TD]
[TD]c[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]11[/TD]
[TD][/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD][/TD]
[TD][/TD]
[TD]c[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]12[/TD]
[TD][/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD="align: right"]13[/TD]
[TD]a[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]13[/TD]
[TD]a[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
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.
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
[TABLE="width: 848"]
<colgroup><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]EKV[/TD]
[TD]V1[/TD]
[TD]V2[/TD]
[TD]V3[/TD]
[TD]V4[/TD]
[TD]V5[/TD]
[TD]V6[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]21[/TD]
[TD][/TD]
[TD]SR2[/TD]
[TD]SR3[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]112[/TD]
[TD]SR1[/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]115[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]117[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]349[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]352[/TD]
[TD][/TD]
[TD]SR2[/TD]
[TD]SR3[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]1417[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]1980[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]2458[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]3558[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]3575[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[/TR]
[TR]
[TD="align: right"]3592[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR3[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[/TR]
</tbody>[/TABLE]


Output:
[TABLE="width: 608"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]EKV[/TD]
[TD]V1[/TD]
[TD]V2[/TD]
[TD]V3[/TD]
[TD]V4[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]21[/TD]
[TD]SR4[/TD]
[TD]SR2[/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]112[/TD]
[TD]SR1[/TD]
[TD]SR5[/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]115[/TD]
[TD]SR4[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]117[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]349[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]352[/TD]
[TD]SR4[/TD]
[TD]SR2[/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]1417[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]1980[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]2458[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]3558[/TD]
[TD][/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]3575[/TD]
[TD]SR5[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD]SR3[/TD]
[/TR]
[TR]
[TD="align: right"]3592[/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD]SR6[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]SR3[/TD]
[TD][/TD]
[TD][/TD]
[TD]


[/TD]
[/TR]
</tbody>[/TABLE]
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
 
Upvote 0
Try this:-
If not what you want please show example of expected results.
NB:- This code takes a few seconds to Run.
Code: 
[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
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Lookup Material Name Material Unit/Day Consumed Duration and accumulate and compact abstract to the destination
Replies
2
Views
79
abuharvey
A
Jeffrey Mahoney
  • Solved
LET Function Letting Me Down
Replies
7
Views
181
Jeffrey Mahoney
Jeffrey Mahoney
W
  • Question Question
Data lookup based upon date range
Replies
2
Views
107
bebo021999
B
R
  • Solved
How to independently sort multiple columns of this SEQUENCE output without effecting the positions of the columns and of the blanks?
2
Replies
15
Views
459
Rnkhch
R
D
  • Question Question
If formula with date & VLOOKUP
Replies
1
Views
254
etaf
etaf

Forum statistics

Threads
1,223,227
Messages
6,170,853
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top