• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Summary table from 3 different tables

R

ravikiran

Member
Hi Excel gurus,

I need some help with a specific requirement to merge 3 tables into 1 summary table. Unfortunately, I cannot install or use PowerPivot for this purpose. I attached sample data file and also added screenshot of tables + expected output.
62915
Expected output: I am finding it particularly difficult achieve the column "Countries from". Rest I am able to get using a Pivot table. I am hoping this might be possible with a VBA macro.
62918
Thanks for looking into this.

Ravi.
 

Attachments

  • Summary of 3 Tables.xlsm
    12.8 KB · Views: 15
Hi !​
​
According to your attachment, a starter demonstration to paste to the (Sheet1) worksheet module :​
Code: 
Sub Demo1()
             Dim oList As ListObject, C$, oRow As ListRow, V, W(), X, R&
             [D19].CurrentRegion.Offset(1).Clear
    With CreateObject("Scripting.Dictionary")
        For Each oList In Me.ListObjects
             C = oList.Range(1)(0).Text
            For Each oRow In oList.ListRows
                    V = Application.Index(oRow.Range.Resize(, 4), , [{1,2,4,3,4}])
                    V(3) = C
                If .Exists(V(1)) Then
                        W = .Item(V(1)):      V(1) = ""
                        X = Application.Match(V(2), Application.Index(W, , 2), 0)
                    If IsError(X) Then
                        ReDim Preserve W(UBound(W) + 1)
                        W(UBound(W)) = V
                    Else
                        W(X - 1)(3) = W(X - 1)(3) & ", " & C
                        W(X - 1)(4) = W(X - 1)(4) + V(4)
                    End If
                       .Item(W(0)(1)) = W
                Else
                   .Add V(1), Array(V)
                End If
            Next
        Next
                 R = 20
        For Each V In .Items
                 V(UBound(V))(5) = Application.Sum(Application.Index(V, , 4))
            With Rows(R).Columns("D:H").Resize(UBound(V) + 1)
                .Value2 = Application.Index(V, 0)
                .Borders(xlEdgeBottom).Weight = xlThin
                .Borders(xlEdgeBottom).ColorIndex = 55
            End With
                 R = R + UBound(V) + 1
        Next
           .RemoveAll
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
 
@Hany ali & @ravikiran

Why not use Power Query to do the merge. You won't be able to get it in the exact format (with merged cells or blank cells), but that is just cosmetic.

If you have Excel 2013 or above, you can use it.

Follow below steps.

  1. Open new file, go to Data > New Connection > Excel and point t your source file.
  2. Get any one table (tblSpain) say.
  3. In Power Query editor, remove the steps so you can look all tables
  4. Filter to just tables
  5. Now, keep only Name & Table columns
  6. Expand Table column so you get all data
  7. Replace tbl with nothing so you end up with country names in Name column
  8. Select Fruit and Variety column, goto Transform > Group by
  9. Switch to "Advanced" options in group by. Add Sum of quantity and "All rows" as Data
  10. Group
  11. You end up with table shown in below picture (1)

    pic-1-grouped-rows.PNG

  12. Sort the table on fruit and variety
  13. Add new custom column and write the formula [data][Name] to extract all names as list
  14. Extract the list, but select "Extract values..." and set delimiter as ,
  15. Remove the Data column
  16. re arrange columns and your data is ready
pic-2-final-data.PNG

The best part is you can refresh this on demand or add steps to make your life simple.
 
Marc L said:
Hi !​
​
According to your attachment, a starter demonstration to paste to the (Sheet1) worksheet module :​
Code: 
Sub Demo1()
             Dim oList As ListObject, C$, oRow As ListRow, V, W(), X, R&
             [D19].CurrentRegion.Offset(1).Clear
    With CreateObject("Scripting.Dictionary")
        For Each oList In Me.ListObjects
             C = oList.Range(1)(0).Text
            For Each oRow In oList.ListRows
                    V = Application.Index(oRow.Range.Resize(, 4), , [{1,2,4,3,4}])
                    V(3) = C
                If .Exists(V(1)) Then
                        W = .Item(V(1)):      V(1) = ""
                        X = Application.Match(V(2), Application.Index(W, , 2), 0)
                    If IsError(X) Then
                        ReDim Preserve W(UBound(W) + 1)
                        W(UBound(W)) = V
                    Else
                        W(X - 1)(3) = W(X - 1)(3) & ", " & C
                        W(X - 1)(4) = W(X - 1)(4) + V(4)
                    End If
                       .Item(W(0)(1)) = W
                Else
                   .Add V(1), Array(V)
                End If
            Next
        Next
                 R = 20
        For Each V In .Items
                 V(UBound(V))(5) = Application.Sum(Application.Index(V, , 4))
            With Rows(R).Columns("D:H").Resize(UBound(V) + 1)
                .Value2 = Application.Index(V, 0)
                .Borders(xlEdgeBottom).Weight = xlThin
                .Borders(xlEdgeBottom).ColorIndex = 55
            End With
                 R = R + UBound(V) + 1
        Next
           .RemoveAll
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
Click to expand...

Thanks Marc. This is Awesome.

I would love to understand what's happening internally. I am trying to adapt it to the original data, which has some intervening columns within the tables. Will get back.

Cheers,
Ravi.
 
To follow the code execution just place a break point within the code via the F9 key​
then run the demonstration and check worksheet and variables contents in the Locals VBE window.​
You can also progress in step by step mode hitting the F8 key …​
​
Attaching a workbook which not respects exactly the original layout means​
you are very confident of your VBA skills to fit the code to your original workbook !​
​
 
Marc L said:
To follow the code execution just place a break point within the code via the F9 key​
then run the demonstration and check worksheet and variables contents in the Locals VBE window.​
You can also progress in step by step mode hitting the F8 key …​
​
Attaching a workbook which not respects exactly the original layout means​
you are very confident of your VBA skills to fit the code to your original workbook !​
​
Click to expand...
Thanks Marc. Yes I am comfortable with VBA, though I cannot say the same about Arrays. Unfortunately, it has never been my strong point. And your solution is very innovative. Once I got hang of it, I adjusted the code to work with my original table layout.

I am able to build the summary using ADO query, but the concatenated country names became a struggle.

One last question if I may - How can I insert new rows depending on the size of the array? The report will be printed (or PDF'd) in between few paragraphs of text. I got a workaround pulling the bottom section from another worksheet, but I would prefer not to do so if I can.

Thanks again for your help.

Cheers,
Ravi.
 
The easy way to insert new rows is to directly operate on the worksheet.​
With a 2D array only the last dimension (columns) can accept a redimension (via Redim Preserve)​
but you can apply a transposition like you have to when using ADO …​
Or use embedded arrays like in my previous demonstration, the first level array must have a single dimension.​
​
According to your attachment a variation maybe easier on array side to paste to the (Sheet1) worksheet module :​
Code: 
Sub Demo2()
             Const F = 20
             Dim oList As ListObject, C$, oRow As ListRow, V, K$, W, R&, Rg As Range
             Cells(F, 4).CurrentRegion.Offset(1).Clear
    With CreateObject("Scripting.Dictionary")
        For Each oList In Me.ListObjects
             C = oList.Range(1)(0).Text
            For Each oRow In oList.ListRows
                    V = Application.Index(oRow.Range, , [{1,2,3,3}])
                    K = V(1) & "¤" & V(2)
                If .Exists(K) Then
                    W = .Item(K)
                    W(3) = W(3) & ", " & C
                    W(4) = W(4) + V(4)
                   .Item(K) = W
                Else
                    V(3) = C
                   .Add K, V
                End If
            Next
        Next
             R = .Count:   If R = 0 Then Exit Sub
         Set Rg = Cells(F, 4).Resize(R, 4)
             Rg.Value2 = Application.Index(.Items, 0)
            .RemoveAll
    End With
    If R > 1 Then
             Rg.Sort Rg(1), xlAscending, Rg(2), , xlAscending, Header:=xlNo
        With Rg.Columns(5)
           C = .Offset(, -4).Address(, , xlR1C1)
           K = .Offset(, -1).Address(, , xlR1C1)
               .FormulaR1C1 = "=IF(RC[-4]=R[1]C[-4],"""",SUMIF(" & C & ",RC[-4]," & K & "))"
               .Formula = .Value2
        End With
        With Rg(2, 1).Resize(R - 1)
            .Value2 = Me.Evaluate("IF(" & .Offset(-1).Address & Replace("=#,"""",#)", "#", .Address))
        End With
               Set Rg = Rg(R, 1)
        Do
                   Rg.Resize(, 5).Borders(xlEdgeBottom).Weight = xlThin
                If Rg.Value2 = "" Then Set Rg = Rg.End(xlUp)(0) Else Set Rg = Rg(0)
        Loop While Rg.Row > F
    End If
               Set Rg = Nothing
End Sub
You may Like it !​
​
 
good,sorry mr Marc
pls which Missing Library with me to let this Code work with me ?
 

Attachments

  • Untitled.png
    Untitled.png
    112.6 KB · Views: 10
As I'm on a smartphone and according to your picture the result will be the same so​
it's better to know which codeline raises the error as you can check in step by step mode hitting F8 key.​
Expecting too a revert from ravikiran to know how it works on his side …​
​
 
Hi Marc,

Apologies for my delay. Been busy with a workshop and didn't get to post back. Yes the code did work for me except for a minor issue.

Not sure why, but when I adapted the code to work with my data the column that is synchronous to "Countries from" data is being duplicated. The final report is otherwise perfect. So I tackled the duplication with a Find and Replace for the time-being. Need to look into that this week once I get sometime.

Cheers,
Ravi.
 
You must log in or register to reply here.
Back
Top