Rearranging Excel Data using VBA

Question

Hello I am trying to reaarange the data in excel using VBA. Current Data is

Project Task    Resource
P1  T1  R1
P1  T1  R2
P1  T3  R3
P1  T3  R4
P1  T3  R5
P2  T6  R6
P2  T7  R7

I want it to look like:

Project Task    Resource        
P1  T1  R1  R2  
P1  T3  R3  R4  R5
P2  T6  R6      
P2  T7  R7      

The resources are spread out based on project and task. I wanted to first test project and task and so I wrote:

Sub Test()
    Dim rw As Long, cl As Long
    Dim Text As String
    Dim Text2 As String

    With ActiveSheet
        For rw = .Cells(Rows.Count, 1).End(xlDown).Row To 6 Step 1
            For cl = .Cells(rw, Columns.Count).End(xlToLeft).Column To 3 Step 1
                If Not IsEmpty(.Cells(rw, cl)) Then
                    Text = Cells(rw, 1).Value
                    Text2 = Cells(rw + 1, 1).Value
                    If Text = Text2 Then
                        .Columns(cl + 1).Insert
                        .Cells(rw, cl + 1) = .Cells(rw, cl + 1).Value2
                        '.Cells(rw + 1, 2) = .Cells(rw, cl).Value2
                        .Cells(rw, cl).Clear
                    End If

                End If
            Next cl
        Next rw
    End With
End Sub

Upon debugging I realized the cursor moves from

For rw = .Cells(Rows.Count, 1).End(xlDown).Row To 6 Step 1

to

 End With

directly.

What am I doing wrong and is there an easy code to do the required thanks.

I changed the code s little: this is the new code:

Sub Test()
Dim rw As Long, cl As Long
Dim Text As String
Dim Text2 As String
Dim Flag As Integer

With ActiveSheet
    For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        For cl = .Cells(rw, Columns.Count).End(xlToLeft).Column To 2 Step -1
            If Not IsEmpty(.Cells(rw, cl)) Then
                Text = Cells(rw, 1).Value
                Text2 = Cells(rw - 1, 1).Value
                If Text = Text2 Then
                    Flag = Flag + 1
                    '.Columns(cl + 1).Insert
                    .Cells(rw, cl + Flag) = .Cells(rw, cl).Value2
                    '.Cells(rw, cl).Clear

                End If

            End If
        Next cl
    Next rw
End With

End Sub

The output is nowhere close to what i want:

Project Task                    
P1  T1                  
P1  T1                  T1
P1  T3              T3  
P1  T3          T3      
P1  T3      T3          
P2  T6                  
P2  T7  T7              

Answer 1

Here's a different approach using dictionaries instead to produce the desired result.

The idea is to read the data rows (as strings) to a dictionary, using a key consisting of Project and Task. If the key for a row does not already exist in the dictionary, it will be added. If it already exists, append the additional Resource. Like this, the seven rows of data will produce a dictionary with four string items representing the desired output. The last step is to read the content of the dictionary to the worksheet.

Assuming that the data is located in range A1:C7, the code below produces the result in the following screenshot, with the desired output in range E1:I4.

Note that this requires that you set a reference to Microsoft Scripting Runtime as shown in the code below.

Sub TestWithDict()
' Requires that the VBA project has a reference to Microsoft Scripting Runtime;
' choose Tools > References > Microsoft Scripting Runtime
    Dim myDict As Scripting.Dictionary
    Dim rngData, rngTarget As Range
    Dim sRowString, sRowKey As String
    Dim sArray() As String
    Dim i, j As Integer

    Set myDict = New Scripting.Dictionary
    Set rngData = ActiveSheet.UsedRange

    ' Loop through the rows:
    For Each rRow In rngData.Rows
        ' Build a string from the row:
        sRowString = rRow.Cells(, 1).Value & ";" & rRow.Cells(, 2).Value & _
            ";" & rRow.Cells(, 3).Value
        ' Use Project and Task to create a key for the dictionary:
        sRowKey = rRow.Cells(, 1).Value & ";" & rRow.Cells(, 2).Value
        ' Save the string to the Dictionary:
        ' 1) If it doesn't already exist, add it:
        If Not myDict.Exists(sRowKey) Then
            myDict.Add sRowKey, sRowString
        ' 2) If it already exists, append the resource from the third column:
        Else
            myDict.Item(sRowKey) = myDict.Item(sRowKey) & ";" & rrow.Cells(, 3).Value
        End If
    Next rrow
    ' After completing the For block, the dictionary contains 
    ' four strings representing each row in the desired output.

    ' Write the strings in the dictionary to the worksheet:
    Set rngTarget = ActiveSheet.Range("E1")
    i = 0
    For Each sItem In myDict.Items
        sArray = Split(sItem, ";")
        Debug.Print sArray(0), sArray(1), sArray(2)
        For j = 0 To UBound(sArray)
            rngTarget.Offset(i, j) = sArray(j)
        Next j
        i = i + 1
    Next sItem
End Sub

Answer 2

Try this.

Sub test()
    Dim d As Object, vS As Variant
    Dim vDB, a, vR()
    Dim s As String
    Dim i As Long, n As Long
    Dim j As Integer, c As Integer


    vDB = Range("a1", Range("c" & Rows.Count).End(xlUp))
    n = UBound(vDB, 1)

    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To n
        s = vDB(i, 1) & "," & vDB(i, 2)
        If d.Exists(s) Then
        Else
            d.Add s, i
        End If
    Next i
    a = d.keys
    ReDim vR(1 To d.Count, 1 To 10)
    For i = 0 To d.Count - 1
        c = 2
        For j = 1 To n
            s = vDB(j, 1) & "," & vDB(j, 2)
            If s = a(i) Then
                vR(i + 1, 1) = vDB(j, 1)
                vR(i + 1, 2) = vDB(j, 2)
                c = c + 1
                vR(i + 1, c) = vDB(j, 3)
            End If
        Next j
    Next i
    Sheets.Add
    Range("a1").Resize(UBound(vR, 1), UBound(vR, 2)) = vR

End Sub