Finding relation between different cells of each row

[near]

hi

 

[MickG]

This must be a first, an Answer for No Question
Try this on you basic data:-
Your Data starts "A1", Results start "B7".

[COLOR=navy]Sub[/COLOR] MG15Apr46
[COLOR=navy]Dim[/COLOR] Lst  [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] col [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Mc   [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac  [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Rw   [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] rng  [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Mr   [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Num1 [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Num2 [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] dn   [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] rng = Range("A1").CurrentRegion
Lst = Cells("1", Columns.Count).End(xlToLeft).Column
    ReDim Ray(1 To Lst * 2 + 1, 1 To Lst * 2 + 1)
    [COLOR=navy]For[/COLOR] col = 1 To Lst
        [COLOR=navy]For[/COLOR] Rw = 1 To 2
            Ac = Ac + 1
            Ray(1, Ac + 1) = Cells(Rw, col)
            Ray(Ac + 1, 1) = Cells(Rw, col)
        [COLOR=navy]Next[/COLOR] Rw
    [COLOR=navy]Next[/COLOR] col
 
[COLOR=navy]For[/COLOR] Mr = 2 To UBound(Ray, 1)
    [COLOR=navy]For[/COLOR] Mc = 2 To UBound(Ray, 2)
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] dn [COLOR=navy]In[/COLOR] rng
            [COLOR=navy]If[/COLOR] dn = Ray(Mr, 1) [COLOR=navy]Then[/COLOR] Num1 = dn.Row: [COLOR=navy]Exit[/COLOR] For
        [COLOR=navy]Next[/COLOR] dn
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] dn [COLOR=navy]In[/COLOR] rng
            [COLOR=navy]If[/COLOR] dn = Ray(1, Mc) [COLOR=navy]Then[/COLOR] Num2 = dn.Row: [COLOR=navy]Exit[/COLOR] For
        [COLOR=navy]Next[/COLOR] dn
            Ray(Mr, Mc) = IIf(Num1 = Num2, 1, 0)
            Num1 = "": Num2 = ""
    [COLOR=navy]Next[/COLOR] Mc
[COLOR=navy]Next[/COLOR] Mr
Range("B7").Resize(UBound(Ray), UBound(Ray)) = Ray
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[near]

Actually i tried to put my question by using table properties or attachments but couldn't find any. because it is difficult to make you understand my problem without tables. so thats why i decided to not to put the question.
But now, after getting your response, i am very pleased. Now i am putting my exact question. Here it is:
Hi, I want to detect the relationship between values of each row.
For Example:
I have two worksheets say Sheet1 and Sheet2.
Sheet1 data looks like this:
a p q r
b l m q

Here first column is the heading of each row, i.e., a, b.
Second and third column are the related values of each header row, i.e., p, q and r are the related values of a, and similarly l, m and q are the related values of b.
Sheet2 data looks like this:
# a b p q r l m
a 1 0 1 1 1 0 0
b 0 1 0 1 0 1 1
p 1 0 1 1 1 0 0
q 1 1 1 1 1 1 1
r 1 0 1 1 1 0 0
l 0 1 0 1 0 1 1
m 0 1 0 1 0 1 1
Here, I wrote all the data found in Sheet1 as row heading and column heading. I assume this dataset as a matrix. Now I want to fill this matrix by using the relationship. I have to fill it by using 0 and 1. If data is matched then 1 otherwise 0.

Relationship Definition:
In Sheet1, all the data written in row1, i.e., a, p, q and r are related to each other. Now in Sheet2, I have to fill 1 against a*a, a*p, a*q and a*r and all the other entries to 0.
All the data written in row2 (Sheet1) are related to each other. Now in Sheet2, I have to fill 1 against b*b, b*l, b*m and b*q and all the other entries to 0 and so on.
And similarly, you can see the row4 of Sheet2, in which all the data is marked 1 because q is present in both rows of sheet1 and hence it has relation with every value.
I have a huge amount of data to do this job. Any solution using macro will be greatly appreciated.
Thanks,

Note: I have placed the same question on this link "http://www.ozgrid.com/forum/showthread.php?t=164400"...but could not find a solution till now.

 

[MickG]

This is basically the same code, but altered to take account of the Duplicate Letter in sheet (1) data.( i.e "q") that reduces the Matrix size
I note that the Matrix Headers do not take any particular format in relation to sheet (1) range, so I have placed them as you will see.
If this is what you want, I will alter the code to take account of the various sheets and extra data.
NB:- Your data starts "A1" Results Start "B7"

[COLOR="Navy"]Sub[/COLOR] MG16Apr29
[COLOR="Navy"]Dim[/COLOR] Lst  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Mc   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rw   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng  [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Mr   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Num1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Num2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dn   [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A1").CurrentRegion
 ReDim Ray(1 To Rng.Count + 1 + 1, 1 To Rng.Count + 1)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
        
      [COLOR="Navy"]For[/COLOR] col = 1 To Rng.Columns.Count
        [COLOR="Navy"]Set[/COLOR] nRng = Rng(col).Resize(Rng.Rows.Count)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] nRng
                .Item(Dn.Value) = Dn
                 Ac = Ac + 1
                Ray(1, Ac + 1) = .Item(Dn.Value)
                Ray(Ac + 1, 1) = .Item(Dn.Value)
            [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]Next[/COLOR] col
ReDim oMax(1 To 2)
[COLOR="Navy"]For[/COLOR] Mr = 2 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] Mc = 2 To UBound(Ray, 2)
       [COLOR="Navy"]For[/COLOR] Rw = 1 To 2
            [COLOR="Navy"]With[/COLOR] Application
                oMax(Rw) = .CountIf(Rng.Rows(Rw), Ray(1, Mc)) + .CountIf(Rng.Rows(Rw), Ray(Mr, 1))
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] Rw
       Ray(Mr, Mc) = IIf(Application.Max(oMax(1), oMax(2)) = 2, 1, 0)
    [COLOR="Navy"]Next[/COLOR] Mc
[COLOR="Navy"]Next[/COLOR] Mr
Range("B7").Resize(.Count + 1, .Count + 1) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[near]

Yes, its working...Thank you so much...
Can you please help me to little modify this code for another relevant task?
Here is the detail...

1: If There is some data on the first column of Sheet3 and I want to create the matrix based on this data to match first with the relations given in Sheet1.
(In my last post every value in sheet1 was chosen for matrix but now only the values given in the first column of Sheet3 will be used for matrix generation by using the relation given in Sheet2)

For Example: Sheet3 data will be like this:
Sheet3
a
q
b
m

 

[MickG]

Can you show an example of how sheet 3 relates to sheet 1 and what the resulting matrix would look like.

 

[near]

For Example: Sheet3 data will be like this:
Sheet3
a
q
b
m
Sheet1 data will be like this:
a p q r
b l m q
Here a and b are row headings. And relationship definition is already given by me in my last post.
Now Sheet3 data will be searched in Sheet1 and the resultant matrix should be stored in Sheet2 like as follows

# a b m q
a 1 0 0 1
b 0 1 1 1
m 0 1 1 1
q 1 1 1 1

As you can see the resultant matrix is also sorted in ascending order.

Note: # sign is only used to fill the space....so no meaning for # sign in sheet2. And it should not be displayed.

 

[MickG]

Try this for sheets 1,2 & 3.

[COLOR="Navy"]Sub[/COLOR] MG17Apr33
[COLOR="Navy"]Dim[/COLOR] Lst  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Mc   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rw   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng  [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Mr   [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dr
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] DataRay
[COLOR="Navy"]Dim[/COLOR] DRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Sheet3")
    [COLOR="Navy"]Set[/COLOR] DRng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
     DRng.Copy .Range("Z1")
      .Range("Z1").Resize(DRng.Count).Sort .Range("Z1"), xlAscending
       DataRay = .Range("Z1").Resize(DRng.Count)
        .Range("Z1").Resize(DRng.Count).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Sheets("Sheet1").Range("A1").CurrentRegion
   ReDim Ray(1 To DRng.Count + 1, 1 To DRng.Count + 1)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dr [COLOR="Navy"]In[/COLOR] DataRay
                Ac = Ac + 1
                Ray(1, Ac + 1) = Dr
                Ray(Ac + 1, 1) = Dr
            [COLOR="Navy"]Next[/COLOR] Dr
ReDim oMax(1 To 2)
[COLOR="Navy"]For[/COLOR] Mr = 2 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] Mc = 2 To UBound(Ray, 2)
       [COLOR="Navy"]For[/COLOR] Rw = 1 To 2
            [COLOR="Navy"]With[/COLOR] Application
                oMax(Rw) = .CountIf(Rng.Rows(Rw), Ray(1, Mc)) + .CountIf(Rng.Rows(Rw), Ray(Mr, 1))
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] Rw
       Ray(Mr, Mc) = IIf(Application.Max(oMax(1), oMax(2)) = 2, 1, 0)
    [COLOR="Navy"]Next[/COLOR] Mc
[COLOR="Navy"]Next[/COLOR] Mr
Sheets("Sheet2").Range("A1").Resize(DRng.Count + 1, DRng.Count + 1) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[near]

Wow...Thank you so much for your answer...it is working fine on my given sample data in last post.

Can you please make this code to work on big data set? because this solution is only workable for very small data.
In Sheet1, My data has 500 rows and columns ranges from 25 to 40 and all of my data is numeric

 

[MickG]

I could try and guess what you data looks like , but it would be better if you could give me a reasonable sample of the data for sheets "1 & 3", that is sufficient to work on, but at the moments the code wil not run on. !!
You may find if you Place borders around each cell in the range for copying to form a grid then copy and paste to forum, you will get a better result.