CODEWITHSUNDEEP
excelvba
Ronaldo.K
Ronaldo.K

Reputation: 303

Matrix to column excel vba code

I have a matrix of usernames running along the top and application names(wraps) running down the side. We have put an X in each cell where a particular person uses an application but we now need to make a standard table of 2 columns: Username & App Name and then list the users and the associated application used.

Matrix looks like:

Username| jsmith| bspence| tjones 
 Wrap ID|
     abc|           X        X
     def|   X       O
     ghi|   X       X

I need to change to the format:

Username|WrapID | value
Jsmith | abc     | X
Jsmith | ghi     | X
bspence | def    | O
bspence | ghi    | X
tjones | abc     | X

I have tried joining every formula I can think of, if(index(match) among others and am at a complete loss. I dont know any VB but it looks like this is the only solution to the problem.

Any assistance is sincerely appreciated.

I made a code like this, but this give me errors.

Sub ConvertMatrix() 
Dim lngX As Long, vIn, vUser, vOut 
Dim i As Long, j As Long, rngIn As Range, k As Long 
Set rngIn = [a1].CurrentRegion 
vIn = rngIn.Offset(1, 0).Resize(rngIn.Rows.Count - 1).Value 
vUser = rngIn.Resize(, rngIn.Columns.Count - 1).Offset(, 1).Rows(1).Value 
lngX = Application.WorksheetFunction.CountIf(rngIn, "X") 
Redim vOut(1 To lngX, 1 To 3) 
For i = 1 To UBound(vUser, 2) 
    For j = 1 To UBound(vIn, 1) 
        If vIn(j, i + 1) = "X" Then 
            k = k + 1 
            vOut(k, 1) = vUser(1, i) 
            vOut(k, 2) = vIn(j, 1) 
            vOut(k, 3) = vIn(j, i + 1)
        End If 
    Next 
Next 
With Worksheets.Add 
    .Range("A1:B1") = Array("User", "WrapID", "value") 
    .Range("A2").Resize(UBound(vOut, 1), 3).Value = vOut 
End With

End Sub

Many Thnaks

Regards,

Upvotes: 0

Views: 2669

Answers (1)

tigeravatar
tigeravatar

Reputation: 26640

Sub ConvertMatrix()

    Dim arrMatrix As Variant
    Dim arrResults() As Variant
    Dim ResultIndex As Long
    Dim rIndex As Long
    Dim cIndex As Long

    With Range("A1").CurrentRegion
        arrMatrix = .Value
        If Not IsArray(arrMatrix) Then Exit Sub 'No data
        ReDim arrResults(1 To WorksheetFunction.CountA(.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)), 1 To 3)
    End With

    For cIndex = 2 To UBound(arrMatrix, 2)
        For rIndex = 3 To UBound(arrMatrix, 1)
            If Len(arrMatrix(rIndex, cIndex)) > 0 Then
                ResultIndex = ResultIndex + 1
                arrResults(ResultIndex, 1) = arrMatrix(1, cIndex)
                arrResults(ResultIndex, 2) = arrMatrix(rIndex, 1)
                arrResults(ResultIndex, 3) = arrMatrix(rIndex, cIndex)
            End If
        Next rIndex
    Next cIndex

    If ResultIndex > 0 Then
        With Sheets.Add(After:=Sheets(Sheets.Count))
            With .Range("A1").Resize(, UBound(arrResults, 2))
                .Value = Array("Username", "WrapID", "Value")
                .Font.Bold = True
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
            .Range("A2").Resize(ResultIndex, UBound(arrResults, 2)).Value = arrResults
            .UsedRange.EntireColumn.AutoFit
        End With
    End If

    Erase arrMatrix
    Erase arrResults

End Sub

Upvotes: 3

Related Questions