Transpose data from one column based on criteria of a different column with VBA Arrays

**Anasurimbor** · 09-03-2018, 07:04 AM

Hello,

at first I have to say english isn't my first language. But I hope you will understand my problem.

I have attached an example file.

In this I want to tranpose some data from table "Contracts" to table "Overview" for easier filterability. Sadly a PivotTable solution was not viable, since it can't be really filtered the way I need to.

Essentially we want to see which job order has multiple different reciept numbers. And transpose the company names behind the reciept to the table Overview. Max 10 company names. I did this manually in the example Overview.

Not every job order has reciepts. What I didn't show in those table are that every job order has service description. This is for a cable company. So these reciepts are for services like digging a hole to access cables. But not every service has something billable - thats why there are empty cells.

I thought about how to do this in VBA. The only solution I found is maybe load job order rows with the same job order in an array and with a for loop add reciept numbers that are not already contained in the array. And then simply outpout the company name belonging to the reciept per column in the table Overview.

But I don't really know how to start or if there are better options for this kind of problem. Like I don't know how to load job order rows with the same job order number into an array.

Some additional info:

My original data contains over 200.000 rows.

I am using excel 2016.

This is my first time working with arrays, normally I can solve my problems with some for loops and if statements.

I hope someone can help me jump start a solution. Thanks!

**jindon** · 09-03-2018, 07:41 AM

See if this is how you wanted.

Sub tset()
    Dim a, e, s, i As Long, maxCol As Long, n As Long, t As Long
    a = Sheets("contracts").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            .Item(a(i, 1))(a(i, 2)) = Empty
            maxCol = Application.Max(maxCol, .Item(a(i, 1)).Count + 1)
        Next
        ReDim a(1 To .Count, 1 To maxCol)
        For Each e In .keys
            n = n + 1: a(n, 1) = e: t = 1
            For Each s In .Item(e)
                t = t + 1: a(n, t) = s
            Next
        Next
    End With
    With Sheets.Add.Cells(1).Resize(n, maxCol)
        .Value = a
        If maxCol > 2 Then
            .Cells(1, 2).Value = .Cells(1, 2).Value & 1
            .Cells(1, 2).AutoFill .Cells(1, 2).Resize(, maxCol - 2)
        End If
        .Columns.AutoFit
    End With
End Sub

**Anasurimbor** · 09-03-2018, 07:53 AM

Yes, that works perfectly. Thank you very much.

**WideBoyDixon** · 09-03-2018, 08:00 AM

If you're using Windows then you could try something like this:

Public Sub blah()

Dim contractSheet As Worksheet
Dim overviewSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim dict As Object
Dim nextRow As Long
Dim nextCol As Long

Set contractSheet = Sheets("Contracts")
Set overviewSheet = Sheets("Overview")
Set dict = CreateObject("Scripting.Dictionary")

' Clear out overview sheet
With overviewSheet
    .Range("A2:K" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

nextRow = 1
With contractSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        If .Cells(thisRow, "A").Value <> .Cells(thisRow - 1, "A").Value Then
            dict.RemoveAll
            If overviewSheet.Cells(nextRow, "A").Value <> "" Then nextRow = nextRow + 1
            nextCol = 1
        End If
        
        If .Cells(thisRow, "C").Value <> "" Then
            If Not dict.Exists(.Cells(thisRow, "B").Value) Then
                dict.Add .Cells(thisRow, "B").Value, ""
                overviewSheet.Cells(nextRow, "A").Value = .Cells(thisRow, "A").Value
                nextCol = nextCol + 1
                overviewSheet.Cells(nextRow, nextCol).Value = .Cells(thisRow, "B").Value
            End If
        End If
    Next thisRow
End With

End Sub

Edit: Ah, too late I see

WBD

**Anasurimbor** · 09-03-2018, 08:25 AM

Originally Posted by WideBoyDixon

If you're using Windows then you could try something like this:

Public Sub blah()

Dim contractSheet As Worksheet
Dim overviewSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim dict As Object
Dim nextRow As Long
Dim nextCol As Long

Set contractSheet = Sheets("Contracts")
Set overviewSheet = Sheets("Overview")
Set dict = CreateObject("Scripting.Dictionary")

' Clear out overview sheet
With overviewSheet
    .Range("A2:K" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

nextRow = 1
With contractSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        If .Cells(thisRow, "A").Value <> .Cells(thisRow - 1, "A").Value Then
            dict.RemoveAll
            If overviewSheet.Cells(nextRow, "A").Value <> "" Then nextRow = nextRow + 1
            nextCol = 1
        End If
        
        If .Cells(thisRow, "C").Value <> "" Then
            If Not dict.Exists(.Cells(thisRow, "B").Value) Then
                dict.Add .Cells(thisRow, "B").Value, ""
                overviewSheet.Cells(nextRow, "A").Value = .Cells(thisRow, "A").Value
                nextCol = nextCol + 1
                overviewSheet.Cells(nextRow, nextCol).Value = .Cells(thisRow, "B").Value
            End If
        End If
    Next thisRow
End With

End Sub

Edit: Ah, too late I see

WBD

Both work. But I still have a problem.

If I have a job order like in the attachments, where the company name is the same but the reciept number is different, it should output the company name two times (because of the two reciept numbers):
200210751 | ANDRÄ Tief- & Hochbau GmbH | Kabelbau Leipzig GmbH | Kabelbau Leipzig GmbH

**WideBoyDixon** · 09-03-2018, 08:36 AM

Small change then:

Public Sub TransposeContracts()

Dim contractSheet As Worksheet
Dim overviewSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim dict As Object
Dim nextRow As Long
Dim nextCol As Long

Set contractSheet = Sheets("Contracts")
Set overviewSheet = Sheets("Overview")
Set dict = CreateObject("Scripting.Dictionary")

' Clear out overview sheet
With overviewSheet
    .Range("A2:K" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

nextRow = 1
With contractSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        If .Cells(thisRow, "A").Value <> .Cells(thisRow - 1, "A").Value Then
            dict.RemoveAll
            If overviewSheet.Cells(nextRow, "A").Value <> "" Then nextRow = nextRow + 1
            nextCol = 1
        End If
        
        If .Cells(thisRow, "C").Value <> "" Then
            If Not dict.Exists(.Cells(thisRow, "C").Value) Then
                dict.Add .Cells(thisRow, "C").Value, ""
                overviewSheet.Cells(nextRow, "A").Value = .Cells(thisRow, "A").Value
                nextCol = nextCol + 1
                overviewSheet.Cells(nextRow, nextCol).Value = .Cells(thisRow, "B").Value
            End If
        End If
    Next thisRow
End With

End Sub

WBD

**Anasurimbor** · 09-03-2018, 09:01 AM

Originally Posted by WideBoyDixon

Small change then:

Public Sub TransposeContracts()

Dim contractSheet As Worksheet
Dim overviewSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim dict As Object
Dim nextRow As Long
Dim nextCol As Long

Set contractSheet = Sheets("Contracts")
Set overviewSheet = Sheets("Overview")
Set dict = CreateObject("Scripting.Dictionary")

' Clear out overview sheet
With overviewSheet
    .Range("A2:K" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With

nextRow = 1
With contractSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        If .Cells(thisRow, "A").Value <> .Cells(thisRow - 1, "A").Value Then
            dict.RemoveAll
            If overviewSheet.Cells(nextRow, "A").Value <> "" Then nextRow = nextRow + 1
            nextCol = 1
        End If
        
        If .Cells(thisRow, "C").Value <> "" Then
            If Not dict.Exists(.Cells(thisRow, "C").Value) Then
                dict.Add .Cells(thisRow, "C").Value, ""
                overviewSheet.Cells(nextRow, "A").Value = .Cells(thisRow, "A").Value
                nextCol = nextCol + 1
                overviewSheet.Cells(nextRow, nextCol).Value = .Cells(thisRow, "B").Value
            End If
        End If
    Next thisRow
End With

End Sub

WBD

Now that makes sense. It works perfectly. Thanks again, you saved my ***.

**jindon** · 09-03-2018, 08:48 AM

Try change to

Sub test()
    Dim a, e, s, i As Long, txt As String, maxCol As Long, n As Long, t As Long
    a = Sheets("contracts").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            txt = Join(Array(a(i, 2), a(i, 3)), Chr(2))
            .Item(a(i, 1))(txt) = a(i, 2)
            maxCol = Application.Max(maxCol, .Item(a(i, 1)).Count + 1)
        Next
        ReDim a(1 To .Count, 1 To maxCol)
        For Each e In .keys
            n = n + 1: a(n, 1) = e: t = 1
            For Each s In .Item(e)
                t = t + 1: a(n, t) = .Item(e)(s)
            Next
        Next
    End With
    With Sheets.Add.Cells(1).Resize(n, maxCol)
        .Value = a
        If maxCol > 2 Then
            .Cells(1, 2).Value = .Cells(1, 2).Value & 1
            .Cells(1, 2).AutoFill .Cells(1, 2).Resize(, maxCol - 2)
        End If
        .Columns.AutoFit
    End With
End Sub

Transpose data from one column based on criteria of a different column with VBA Arrays

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Re: Transpose data from one column based on criteria of a different column with VBA Arrays

Thread Information

Users Browsing this Thread

Similar Threads

Rewrite VBA script from Column based arrays to Rows based arrays

Transfer data based on value in Column using arrays

multiple look up arrays to sum column based on various criteria

How to sum column arrays based on criteria in multiple rows...?

[SOLVED] Copy data from column to other sheets, based upon vlookup/criteria on column a

Excel Transpose Column to Rows Based on Criteria

Excel Transpose Column to Rows Based on Criteria

Bookmarks

Bookmarks

Posting Permissions