Question

I am trying to make edge relation from excel file which are organized in rows,

A,B,C,

D,E

the aim is to create relationships from each row:

A,B

A,C

B,C

I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):

D,” “

E, ” “

Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.

Thank you so much,Will be great help.

My code:

Sub Transform()

Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2

Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long

Dim sourceRow As Range: For Each sourceRow In Selection.Rows

    For colCounter = 1 To Selection.Columns.Count - 1


        col1 = sourceRow.Cells(colCounter).Value
        For colCounter2 = colCounter + 1 To Selection.Columns.Count
            Set cell = sourceRow.Cells(, colCounter2)

            If Not cell.Column = Selection.Column Then
                Selection.Worksheet.Cells(targetRowNumber, 1) = col1
                Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
                targetRowNumber = targetRowNumber + 1
            End If

        Next colCounter2

    Next colCounter

Next sourceRow

End Sub

Answer 1

I’ve played around with it – this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:

Sub Transform_New()

Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer

Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range

varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value

For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
    For j = LBound(varArray, 2) To UBound(varArray, 2)    'Loop horizontally through each line apart from last cell
        k = j
        Do Until varArray(i, k) = ""
                k = k + 1
                If varArray(i, k) <> "" Then
                    rngDest.Value = varArray(i, j)
                    rngDest.Offset(0, 1).Value = varArray(i, k)
                    Set rngDest = rngDest.Offset(1, 0)
                End If
        Loop
    Next
Next

End Sub