Pull the column title and row title of a matrix

Question

So i have a matrix formatted as so:

|           | joe   | michelle  | tom   |  
|:-----:    |:---:  |:--------: |:---:  |  
|  red      |  1    |     0     |  1    |  
|  blue     |  0    |     1     |  0    |  
| green     |  0    |     0     |  0    |  

I'm trying to write VBA in excel to create two columns based on this table. If the cell inside the matrix is equal to "1", then I want to write the column name and row name into a list. So for example, because row "red" has a "1" in columns "joe" and "tom", and row "blue" has a "1" under "michelle", my new table would be like this:

|    joe    |  red  |  
|    tom    |  red  |  
| michelle  | blue  | 

Here is the VBA i wrote so far, but it doesn't work and i hit a road block.

sub subname()  
dim i as integer  
for i = 1 to 3  
  if cells(2,i).value=1 then  
    cell(5,i).value = cells(1,i).value  
  end if  
next i  
end sub  

Answer 1

You have only one cycle ...

Dim x As Integer

Range("B19").Select
x = 4
For i = 1 To 3  ' Row
    For e = 1 To 3  ' Column
        If ActiveCell.Offset(i, e).Value = "1" Then
            x = x + 1
            ActiveCell.Offset(x, 0).Value = ActiveCell.Offset(0, e).Value
            ActiveCell.Offset(x, 1).Value = ActiveCell.Offset(i, 0).Value
        End If
    Next
Next

I consider B19 the top_left corner of the table ...
Ok the correct code is:

Dim i As Integer
For i = 1 To 3
  If Cells(2, i + 1).Value = 1 Then
    Cells(5, 1).Value = Cells(1, i + 1).Value
  End If
Next i

If the top_left of the table is A1 The error is the reference of i. You need to add 1 or change the cycle from 2 to 4.
The second "error" it's to put the value in cell(5,i) instead of cells(5,1). In that case you have to put the name in a fix position. In a cycle you change in Cells(5+e,1)...

Answer 2

You can use this code also.

Sub prabhat()
Dim rng As Range
Dim r As Integer
Dim c As Integer
Dim lastRow As Integer
Dim lastRow2 As Integer
Set rng = Range("a2:d4")
For Each dng In rng
lastRow = Range("E" & Rows.Count).End(xlUp).Row
lastRow2 = Range("F" & Rows.Count).End(xlUp).Row
If dng.Value = 1 Then
r = dng.Row
c = dng.Column
Range("E" & lastRow + 1).Value = Cells(r, 1).Value
Range("F" & lastRow2 + 1).Value = Cells(1, c).Value
End If
Next dng
End Sub