Match 7 columns of Data

[Gribbin]

Hi,
I currently have 7 columns of data, "Days Of Week". The names of staff working are in each column. Each column can vary from around 30 to 150. What i would like is if the name is in more than one column then they are aligned. Due to so many records a simple sort alphabetically isn't good enough for what i need. Also they might not be found in every column.

The data is exported from a online application and isn't manually inputted

an example would be

Sunday	Monday	Tuesday	Wednesday	Thursday	Friday	Saturday
John	John	John	John		John
	Adam		Adam	Adam
	James	James
Robert			Robert

<tbody>
</tbody>

The data is in the below format, The text formatting was me trying some things that where far too labor intensive

Thanks in advance for any help

John

 

[MickG]

Try this for data in columns "A to G", Results start "J1".

[COLOR=Navy]Sub[/COLOR] MG16Jan08
[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] Dic [COLOR=Navy]As[/COLOR] Object, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = ActiveSheet.Range("A1").CurrentRegion.Resize(, 7)
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
            Dic.Add Dn.Value, Dn
        [COLOR=Navy]Else[/COLOR]
            [COLOR=Navy]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Dim[/COLOR] K [COLOR=Navy]As[/COLOR] Variant, R [COLOR=Navy]As[/COLOR] Range, Ray() [COLOR=Navy]As[/COLOR] Variant
  [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys
        c = c + 1
        ReDim Preserve Ray(1 To 7, 1 To c)
            [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Dic(K)
                Ray(R.Column, c) = R
            [COLOR=Navy]Next[/COLOR] R
  [COLOR=Navy]Next[/COLOR] K
Range("J1").Resize(c, 7) = Application.Transpose(Ray)
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[erik.van.geit]

Hi, Bribbin,
WELCOME to MrExcel!
Mick has already answered, which I didn't see in time, but anyway I'll post my code too.

'Get values from all columns to the same row
'values will be in order of appearance from left to right
'150116
'Erik Van Geit

Dim RangeToAlign As Range
Dim LR As Long              'last row
Dim LRMax As Long
Dim CC As Long              'columns count
Dim ArrCol As Variant
Dim ArrAllValues As Variant
Dim ArrResults As Variant
Dim ArrUniques
Dim ScriptDicObject As Object
Dim ArrayElement
Dim i As Long
Dim col As Long

Set RangeToAlign = Range("A2:G6")
CC = RangeToAlign.Columns.Count
ArrAllValues = RangeToAlign.Value

ReDim ArrCol(1 To CC)

    'create an array per column
    For col = 1 To CC
    ArrCol(col) = Application.Transpose(RangeToAlign.Columns(col))
    Next col

    'using dictionary to get unique items
Set ScriptDicObject = CreateObject("Scripting.Dictionary")

    With ScriptDicObject
        For Each ArrayElement In ArrAllValues
        If Not IsEmpty(ArrayElement) And Not .Exists(ArrayElement) Then .Add ArrayElement, Empty
        Next
        'copy to an array
        ArrUniques = .keys
    End With

ReDim ArrResults(UBound(ArrUniques), 1 To CC)
    'loop through all items
    For i = 1 To UBound(ArrUniques) + 1
        For col = 1 To CC
            'check if they are in the column
            If Not IsError(Application.Match(ArrUniques(i - 1), ArrCol(col), 0)) Then
            'put in array if match for that column is found
            ArrResults(i - 1, col) = ArrUniques(i - 1)
            End If
        Next col
    Next i

    With RangeToAlign
    'copy headers
    .Offset(-1, CC).Resize(1, CC).Value = .Offset(-1, 0).Resize(1, CC).Value
    'put results on sheet
    .Offset(0, CC).Resize(UBound(ArrResults, 1) + 1, UBound(ArrResults, 2)).Value = ArrResults
    End With
End Sub

By the way: avoid posting "pictures": we can not copy them to Excel. Instead use copy paste.
kind regards,
Erik

 

[Gribbin]

Hi, Thanks for the code MickG it works perfectly as written when the results are pasted in J1

However when I tried to paste on a new worksheet one of the names in each column appeared twice.

i amended this line in your code only

Sheets("Result").Range("A2").Resize(c, 7) = Application.Transpose(Ray)

Any ideas?

John

 

[Gribbin]

Hi Erik,
Thanks for your time and your code. I got run time error "1004" Application-defined or object-defined error on this line

 .Offset(-1, CC).Resize(1, CC).Value = .Offset(-1, 0).Resize(1, CC).Value

Regards

John

 

[erik.van.geit]

Hi Erik,
Thanks for your time and your code. I got run time error "1004" Application-defined or object-defined error on this line

 .Offset(-1, CC).Resize(1, CC).Value = .Offset(-1, 0).Resize(1, CC).Value

Regards

John

you're welcome!
how did you change

Set RangeToAlign = Range("A2:G6")

Do not select the headers.

The trouble is probably

.Offset(-1,0)

this can not be done when the range contains row 1

Tested Micks code: for me the headers are in J2,H3, and further diagonally. Didn't check why.

 

[MickG]

I forgot to allow for headers in the previous code, not sure what that has to do with your findings, but try this:-
This code assumes Row One is your headers Row containing "Weekdays" , as per your Initial Post.
NB:- If this does not work , perhaps you could send an example of the data that fails .

[COLOR="Navy"]Sub[/COLOR] MG17Jan08
[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] Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = ActiveSheet.Range("A1").CurrentRegion.Resize(, 7)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dn.Row = 1 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                Dic.Add Dn.Value, Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, Ray() [COLOR="Navy"]As[/COLOR] Variant
 c = 1
 ReDim Ray(1 To 7, 1 To 1)
 Ray(1, 1) = "Sunday": Ray(2, 1) = "Monday": Ray(3, 1) = "Tuesday"
 Ray(4, 1) = "Wednesday": Ray(5, 1) = "Thursday": Ray(6, 1) = "Friday": Ray(7, 1) = "Saturday"
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
        c = c + 1
        ReDim Preserve Ray(1 To 7, 1 To c)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic(K)
                Ray(R.Column, c) = R
            [COLOR="Navy"]Next[/COLOR] R
  [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Result").Range("A1").Resize(c, 7)
    .Value = Application.Transpose(Ray)
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick