ALIGN DATA CELLS?

[FARAZ QURESHI]

I have a table like:

Column A Column B Column C Column D
Store 1 Store 2 Store 3 Store 4
============================
Dunhill Marlboro Dunhill Kingston
Marlboro Camel More Marlboro
Camel More Camel Dunhill
More Kingston


Could there be a way to arrange the data to be showing similar items on the
same row? For Instance:

Column A Column B Column C Column D
Store 1 Store 2 Store 3 Store 4
============================
Camel Camel Camel
Dunhill Dunhill Dunhill
Kingston Kingston
Marlboro Marlboro Marlboro
More More More

An appropriate array formula or preferably a VBA code shall be highly obliged.

Thanx!

 

[Mike H]

Hi,

Do you really have a row of = signs? This assumes you don't and you just
have a single header row of store 1 etc. If you do have the row of = signs
and can't ammend the code to allow for this then post back. Right click your
sheet tab, view code and paste this in and run it.

I've left an empty row for the = signs if you don't want it then delete it
with the commented out row at the end

Sub AlignColumns()
Columns("A").Copy Destination:=Columns("E")
lrB = Range("B" & Rows.Count).End(xlUp).Row
lrC = Range("C" & Rows.Count).End(xlUp).Row
lrD = Range("D" & Rows.Count).End(xlUp).Row
lrE = Range("E" & Rows.Count).End(xlUp).Row

Range("B2:B" & lrB).Copy Destination:=Range("E" & (lrE + 1))
lrE = Range("E" & Rows.Count).End(xlUp).Row
Range("C2:C" & lrC).Copy Destination:=Range("E" & (lrE + 1))
lrE = Range("E" & Rows.Count).End(xlUp).Row
Range("D2" & lrC).Copy Destination:=Range("E" & (lrE + 1))

lrE = Range("E" & Rows.Count).End(xlUp).Row
Set sRange = Range("E2:E" & lrE)
sRange.Sort _
Key1:=Range("E1"), Order1:=xlAscending, Header:=xlNo

sRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F2"), _
Unique:=True

For cCount = 1 To 4
lRow = Cells(Rows.Count, cCount).End(xlUp).Row
For rCount = 2 To lRow
If Cells(rCount, cCount) <> "" Then
CoffinNail = Cells(rCount, cCount)
Set c = Columns("F").Find(what:=CoffinNail)
c.Offset(0, cCount) = CoffinNail
End If
Next rCount
Next cCount
Range("A11").Copy Destination:=Range("G1")
Columns("A:F").Delete
'Rows(2).Delete
End Sub


Mike

 

[Mike H]

Just thought of a simple fix for the = signs if they exist

Sub AlignColumns()
Columns("A").Copy Destination:=Columns("E")
lrB = Range("B" & Rows.Count).End(xlUp).Row
lrC = Range("C" & Rows.Count).End(xlUp).Row
lrD = Range("D" & Rows.Count).End(xlUp).Row
lrE = Range("E" & Rows.Count).End(xlUp).Row

Range("B2:B" & lrB).Copy Destination:=Range("E" & (lrE + 1))
lrE = Range("E" & Rows.Count).End(xlUp).Row
Range("C2:C" & lrC).Copy Destination:=Range("E" & (lrE + 1))
lrE = Range("E" & Rows.Count).End(xlUp).Row
Range("D2" & lrC).Copy Destination:=Range("E" & (lrE + 1))
lrE = Range("E" & Rows.Count).End(xlUp).Row
Set sRange = Range("E2:E" & lrE)
sRange.Sort _
Key1:=Range("E1"), Order1:=xlAscending, Header:=xlNo

sRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F2"), _
Unique:=True

For cCount = 1 To 4
lRow = Cells(Rows.Count, cCount).End(xlUp).Row
For rCount = 2 To lRow
If Cells(rCount, cCount) <> "" Then
CoffinNail = Cells(rCount, cCount)
Set c = Columns("F").Find(what:=CoffinNail)
With c.Offset(0, cCount)
.NumberFormat = "@"
.Value = CoffinNail
End With
End If
Next rCount
Next cCount
Range("A11").Copy Destination:=Range("G1")
Columns("A:F").Delete
Rows(2).Delete
End Sub

Mike

 

[FARAZ QURESHI]

Sure was a good but quite a lengthy piece of code. Actually it was just a
sample I presented. Can't one have a looping way to deal with multiple
columns or rows?

 

[Don Guillett]

Do you already have a unique list of the values sorted

 

[FARAZ QURESHI]

Sorry I didn't understand you! You mean to say a unique list of the brand
names? If yes then I can it prepare it in by copying all the columns in a
single and remove the duplicates in Excel 2007. By the way that could be
added in the code as well couldn't it?

 

[Mike H]

Hmm,

You didn't ask for variable columns
Sorry I couldn't make it shorter!! thanks for the feedback.

This should now work for any amount of columns

Sub AlignColumns1()
Dim LastRow As Long
lastcol = ActiveSheet.UsedRange.Columns
_(ActiveSheet.UsedRange.Columns.Count).Column
myrow = 1
For c = 1 To lastcol
LastRow = Cells(65536, c).End(xlUp).Row
Range(Cells(LastRow, c), Cells(1, c)).Copy Destination:=Cells(myrow,
lastcol + 1)
myrow = myrow + LastRow
Next c
LR = Cells(65536, lastcol + 1).End(xlUp).Row
Set srange = Range(Cells(1, lastcol + 1), Cells(LR, lastcol + 1))
srange.Sort Key1:=Cells(1, lastcol + 1), Order1:=xlAscending, Header:=xlNo
srange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, lastcol +
2), _
Unique:=True
For cCount = 1 To lastcol
lRow = Cells(Rows.Count, cCount).End(xlUp).Row
For rCount = 2 To lRow
If Cells(rCount, cCount) <> "" Then
CoffinNail = Cells(rCount, cCount)
Set c = Columns(lastcol + 2).Find(what:=CoffinNail)
With c.Offset(0, cCount)
.NumberFormat = "@"
.Value = CoffinNail
End With
End If
Next rCount
Next cCount

Mike

 

[Mike H]

Just noticed Excel 2007, this makes it 2007 proof

Sub AlignColumns1()
Dim LastRow As Long
lastcol =
ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
myrow = 1
For c = 1 To lastcol
LastRow = Cells(Rows.Count, c).End(xlUp).Row
Range(Cells(LastRow, c), Cells(1, c)).Copy Destination:=Cells(myrow,
lastcol + 1)
myrow = myrow + LastRow
Next c
LR = Cells(Rows.Count, lastcol + 1).End(xlUp).Row
Set srange = Range(Cells(1, lastcol + 1), Cells(LR, lastcol + 1))
srange.Sort Key1:=Cells(1, lastcol + 1), Order1:=xlAscending, Header:=xlNo
srange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, lastcol +
2), _
Unique:=True
For cCount = 1 To lastcol
lRow = Cells(Rows.Count, cCount).End(xlUp).Row
For rCount = 2 To lRow
If Cells(rCount, cCount) <> "" Then
CoffinNail = Cells(rCount, cCount)
Set c = Columns(lastcol + 2).Find(what:=CoffinNail)
With c.Offset(0, cCount)
.NumberFormat = "@"
.Value = CoffinNail
End With
End If
Next rCount
Next cCount
Range(Cells(1, 1), Cells(1, lastcol + 2)).Copy Destination:=Cells(1, lastcol
+ 3)
Range(Cells(1, 1), Cells(1, lastcol + 2)).EntireColumn.Delete
Rows(2).Delete
End Sub



Mike

 

[FARAZ QURESHI]

Thanx a lot Mike!

But the code doesn't seem to be working and showed a couple of red lines
when pasted on the VBA editor and run. Sure would appreciate if you would
refine it somehow!

Thanx again, pal!!!!

 

[FARAZ QURESHI]

And by the way with Excel 2007 the last row won't be restricted to 65536.
Can't we use the xlup/xldown technique instead?

 

[Mike H]

The red lines will simply be line-wrap and this should cure that. It goes in
as worksheet code

Sub AlignColumns1()
Dim LastRow As Long
lastcol = ActiveSheet.UsedRange.Columns _
(ActiveSheet.UsedRange.Columns.Count).Column
myrow = 1
For c = 1 To lastcol
LastRow = Cells(Rows.Count, c).End(xlUp).Row
Range(Cells(LastRow, c), Cells(1, c)).Copy _
Destination:=Cells(myrow, lastcol + 1)
myrow = myrow + LastRow
Next c
LR = Cells(Rows.Count, lastcol + 1).End(xlUp).Row
Set srange = Range(Cells(1, lastcol + 1), _
Cells(LR, lastcol + 1))
srange.Sort Key1:=Cells(1, lastcol + 1), _
Order1:=xlAscending, Header:=xlNo
srange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(1, lastcol + 2), _
Unique:=True
For cCount = 1 To lastcol
lRow = Cells(Rows.Count, cCount).End(xlUp).Row
For rCount = 2 To lRow
If Cells(rCount, cCount) <> "" Then
CoffinNail = Cells(rCount, cCount)
Set c = Columns(lastcol + 2).Find(what:=CoffinNail)
With c.Offset(0, cCount)
..NumberFormat = "@"
..Value = CoffinNail
End With
End If
Next rCount
Next cCount
Range(Cells(1, 1), Cells(1, lastcol + 2)).Copy _
Destination:=Cells(1, lastcol + 3)
Range(Cells(1, 1), Cells(1, lastcol + 2)) _
..EntireColumn.Delete
Rows(2).Delete
End Sub

Mike

 

[FARAZ QURESHI]

YAHOO!!!

XCLENT!!!

THANX!!!

U GUYZ R SIMPLY THE BEST!!!!!!!

Any idea how to learn devising such xclent codes/macros/addins????

By the way what is a worksheet code? U mean it can't be inserted into a
separate module?

 

[Mike H]

Hi,

It can go in a general module you'll just have to ensure that the sheet you
working on is the active sheet

sheets("Sheet1").select

or whichever sheet you want as the first line in the code

Mike

 

[Mike H]

Any idea how to learn devising such xclent codes/macros/addins????


Others may disagree with your assesment of the excellence of this code but
to learn you could do worse than hang around in these forums and I would
recommend any of the MVP sites and John Walkenbach's books.

Mike

 

[Don Guillett]

Assumes NO header row. Correct for word wrap where you see red text

Sub doitall()
'make list
lcol = Cells.Find("*", Cells(1, Columns.Count), , , xlByColumns,
xlPrevious).Column
lRow = Cells.Find("*", Cells(Rows.Count, 1), , , xlByRows, xlPrevious).Row
For c = 1 To lcol 'columns
slr = Cells(Rows.Count, c).End(xlUp).Row
dlr = Cells(Rows.Count, lcol + 1).End(xlUp).Row + 1
Cells(2, c).Resize(slr).Copy Cells(dlr, lcol + 1)
Next c

'make unique list from list
Cells(1, lcol + 1).Value = "x"
LR = Cells(Rows.Count, lcol + 1).End(xlUp).Row
Range(Cells(2, lcol + 1), Cells(LR, lcol + 1)) _
.Sort Key1:=Cells(2, lcol + 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range(Cells(1, lcol + 1), Cells(LR, lcol + 1)).AdvancedFilter
Action:=xlFilterCopy, CopyToRange:=Cells(1, lcol + 2), Unique:=True
'arrange
For Each c In Range(Cells(2, lcol + 2), Cells(LR, lcol + 2))
For i = 1 To 4
For j = 1 To 4
If Cells(i, j) = c Then c.Offset(, j + 1) = c

Next j
Next i
Next c
End Sub