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

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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

M
  • Question Question
Token replace between two files with dynamic refresh
Replies
1
Views
87
Rijnsent
Rijnsent
H
  • Solved
Copy non-empty cells from the same column from multiple sheets to a sheet "Breeders"
Replies
6
Views
72
mumps
mumps
A
  • Question Question
Lookup Material Name Material Unit/Day Consumed Duration and accumulate and compact abstract to the destination
Replies
2
Views
95
abuharvey
A
K
  • Solved
Index with Multiple Conditions
Replies
2
Views
110
kivikatz
K
O
  • Solved
Conditional Format Compare Ranges
Replies
3
Views
35
Fluff
Fluff

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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