Find one or multiple unique numbers, create table and do sum on category for that num

Kaherdin · Mar 8th 2012

I'm trying to develop a workbook that can take "raw" input data and then filter it into a predefined report sheet that will make the "raw data" understandable and make for allot easier reading for the recipient of that report.

The raw input data should always contain one RefNo, a category and a total sum of that specific row inserted. That is right now not an issue.

One sheet of this “raw” data usually contains one up to five different RefNo’s.
I want to;
1. Identify the different unique RefNo’s
2. For each RefNo do SUM based on what category there are specified
3. On a different sheet ("Report sheet") create one table for each unique RefNo defined in the "raw-data" sheet
4. Insert the category based sums into corresponding RefNo table

These category sums, all with the same RefNo, should then be inserted into a “Report sheet” and into a simplified table; a table of content so to speak. In my attached file the "simplified table" is marked with red outlines.

Because of the fact that the “raw data”-sheet can contain one up to a multiple unique RefNo’s I can never build “empty” simplified tables on the report sheet to be filled, but instead I want to create one “table” for each unique RefNo from the “raw-data”-sheet.

I have tried to implement the pivot table functions to do this but right now I am not aware of any way of exporting specific data to a specific cell and the issue with how many tables that should be created on the “report-sheet” still remains.

I have learned allot during the last couple of weeks on this forum and I hope that someone with better knowledge of excel and/or VBA could give me a helping hand here.

Please se attached file for further description of my problem.

jindon · Mar 8th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

try

Code

Sub test()
Dim a, i As Long, w(), e, n As Long, y
a = Sheets("mastersheet").Range("b10").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(a, 1)
        If Not .exists(a(i, 9)) Then
            Set .Item(a(i, 9)) = _
            CreateObject("System.Collections.SortedList")
        End If
        a(i, 3) = StrConv(a(i, 3), 3)
        .Item(a(i, 9))(a(i, 3)) = .Item(a(i, 9))(a(i, 3)) + a(i, 8)
    Next
    For Each e In .keys
        ReDim w(1 To 6, 1 To 6)
        w(1, 1) = "RefNo"
        w(5, 1) = "Total Sum"
        w(1, 2) = e
        For i = 0 To .Item(e).Count - 1
            w(2, i + 1) = .Item(e).GetKey(i)
            w(3, i + 1) = .Item(e).GetByIndex(i)
            w(6, 1) = w(6, 1) + w(3, i + 1)
        Next
        .Item(e) = w
    Next
    y = .items
End With
With Sheets("2BPrinted")
    With .Range("b16")
        .Resize(Rows.Count - 16).EntireRow.Clear
        For i = 0 To UBound(y)
            With .Offset(n).Resize(6, 6)
                .Value = y(i)
                .Rows("2:3").Borders.Weight = 2
                .Range("a5").Resize(2).Borders.Weight = 2
                .BorderAround -4119, 2, 3
                .Rows.AutoFit
            End With
            n = n + 10
        Next
    End With
End With
End Sub

Display More

Kaherdin · Mar 8th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Holy excel guru. Ok, I thought it might take a week or so, but your sub worked right out of the box.
I am so greatly impressed.
- Thank you!
I think im gonna love this forum for the rest of my excel-life!

jindon · Mar 8th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Thanks for the feedback.

Can you edit your last post and delete quoted message?

The forum doesn't allow full quotes unless it is really needed.

Edit

I think number of categories should increase more than 6, so the code should

Code

Sub test()
Dim a, i As Long, w(), e, n As Long, maxCol As Long, y
a = Sheets("mastersheet").Range("b10").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(a, 1)
        If Not .exists(a(i, 9)) Then
            Set .Item(a(i, 9)) = _
            CreateObject("System.Collections.SortedList")
        End If
        a(i, 3) = StrConv(a(i, 3), 3)
        .Item(a(i, 9))(a(i, 3)) = .Item(a(i, 9))(a(i, 3)) + a(i, 8)
        maxCol = Application.Max(maxCol, .Item(a(i, 9)).Count)
    Next
    maxCol = Application.Max(maxCol, 6)
    For Each e In .keys
        ReDim w(1 To 6, 1 To maxCol)
        w(1, 1) = "RefNo"
        w(5, 1) = "Total Sum"
        w(1, 2) = e
        For i = 0 To .Item(e).Count - 1
            w(2, i + 1) = .Item(e).GetKey(i)
            w(3, i + 1) = .Item(e).GetByIndex(i)
            w(6, 1) = w(6, 1) + w(3, i + 1)
        Next
        .Item(e) = w
    Next
    y = .items
End With
With Sheets("2BPrinted")
    With .Range("b16")
        .Resize(Rows.Count - .Row).EntireRow.Clear
        For i = 0 To UBound(y)
            With .Offset(n).Resize(6, maxCol)
                .Value = y(i)
                .Rows("2:3").Borders.Weight = 2
                .Range("a5").Resize(2).Borders.Weight = 2
                .BorderAround -4119, 2, 3
                .Rows.AutoFit
            End With
            n = n + 10
        Next
    End With
End With
End Sub

Display More

Kaherdin · Mar 8th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Thank. Will test tomorrow when at work.
Next thing for me is to learn how to format the table that your code generates on the Reportsheet.
I.e. the red lines wont be there in the end, and row height and font size must be corrected. I'll try to google it and hopefully find a good answer.
If you have any tips for where to learn formatting through code it would be much appreciated. Especially row height and font size...

jindon · Mar 8th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

All you need is change this part

Code

With Sheets("2BPrinted") 
        With .Range("b16") 
            .Resize(Rows.Count - .Row).EntireRow.Clear 
            For i = 0 To UBound(y) 
                With .Offset(n).Resize(6, maxCol) 
                    .Value = y(i) 
                    .Rows("2:3").Borders.Weight = 2 
                    .Range("a5").Resize(2).Borders.Weight = 2 
                    .BorderAround -4119, 2, 3 
                    .Rows.AutoFit 
                End With 
                n = n + 10 
            Next 
        End With 
    End With

Display More

to something like

Code

With Sheets("2BPrinted")
    With .Range("b16")
        .Resize(Rows.Count - .Row).EntireRow.Clear
        For i = 0 To UBound(y)
            With .Offset(n).Resize(6, maxCol)
                .Value = y(i)
                .Rows.RowHeight = 16 '<- change to suite
                With .Rows(2)
                    .Font.Size = 7   '<- change to suite
                    .RowHeight = 10  '<- change to suite
                    .Resize(2).Borders.Weight = 2
                End With
                With .Range("a5")
                    .Font.Size = 7   '<- change to suite
                    .RowHeight = 10  '<- change to suite
                    .Resize(2).Borders.Weight = 2
                End With
                .BorderAround 1, 2, -4105
            End With
            n = n + 10
        Next
    End With
End With

Display More

Kaherdin · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Jindon; I have tried your sub with changes to font size and it all works perfectly.
Thank you.

The one thing that might be an issue for me now is the fact that below the tables you helped me create on sheet "2BPrinted" are more tables, and more text and everytime I run the sub "test" that you made for me everything below row B16 is being removed.
- Maybe you know how to keep cell values below B16 and just "insert new rows" or maybe the answer would be to write additional code that after sub test has finshed will paste from another sheet (lets call it 2BPasted) the remaining text that needs to be on 2BPrinted?

Also, and this for you will be an easy question, I need to reduce the number of rows inbetween the summary tables from four to one row.
I am very greatfull for your help!

jindon · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Can just upload the sheet showing the position of the words comes after the last table (dummy is fine) with just one table?
So that I can imagine better.

You can play the line of

Code

n = n + 10

with changing 10 to something else.

Kaherdin · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

forum.ozgrid.com/index.php?attachment/44341/

Here I have inserted some expamples of how test could be placed already in sheet "2BPrinted".
The key question is, as I see it;
1. How to not delete the text and tables already present in the sheet "2BPrinted" or
2. How to after sub test in run insert the text and tables one or two rows below the last summary table created by sub test

jindon · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

I've just looked at the file,,,

1) Is "Title2" always the same or could be anything ?
2) Other table 1 and Total sum at the bottom are related with the formula.
Are they always like that? and the numbers in "Other table 1" are inserted already?

jindon · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

try
One condition:

Whatever the "Title 2" is, must be used "Bold" font.

Code

Sub test()
    Dim a, i As Long, w(), e, n As Long, maxCol As Long, y, myCount As Long
    a = Sheets("mastersheet").Range("b10").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 9)) Then
                Set .Item(a(i, 9)) = _
                CreateObject("System.Collections.SortedList")
            End If
            a(i, 3) = StrConv(a(i, 3), 3)
            .Item(a(i, 9))(a(i, 3)) = .Item(a(i, 9))(a(i, 3)) + a(i, 8)
            maxCol = Application.Max(maxCol, .Item(a(i, 9)).Count)
        Next
        maxCol = Application.Max(maxCol, 6)
        For Each e In .keys
            ReDim w(1 To 6, 1 To maxCol)
            w(1, 1) = "RefNo"
            w(5, 1) = "Total Sum"
            w(1, 2) = e
            For i = 0 To .Item(e).Count - 1
                w(2, i + 1) = .Item(e).GetKey(i)
                w(3, i + 1) = .Item(e).GetByIndex(i)
                w(6, 1) = w(6, 1) + w(3, i + 1)
            Next
            .Item(e) = w
        Next
        y = .items: myCount = .Count * 7
    End With
    CleanSheet
    With Sheets("2BPrinted")
        .Range("b16").Resize(myCount).EntireRow.Insert
        With .Range("b16")
            For i = 0 To UBound(y)
                With .Offset(n).Resize(6, maxCol)
                    .Value = y(i)
                    .Rows.RowHeight = 16 '<- Raden inneh虱lande summorna
                    With .Rows(2)
                        .Font.Size = 7 '<- Kategoriradens fontstorlek
                        .RowHeight = 10 '<- Kategoriraden
                        .Resize(2).Borders.Weight = 2
                    End With
                    With .Range("a5")
                    'Detta 舐 slutsumman p・varje enskilt RefNo
                        .Font.Size = 7 '<- change to suite
                        .RowHeight = 10 '<- change to suite
                        .Resize(2).Borders.Weight = 2
                    End With
                    '.BorderAround 1, 2, -4105 '<- Ramen runt hela tabellen f varje RefNo
                End With
                n = n + 7
            Next
        End With
    End With
End Sub








Private Sub CleanSheet()
    Dim r As Range
    With Application.FindFormat
        .Clear
        .Font.Bold = True
    End With
    With Sheets("2BPrinted")
        Set r = .Range("b16", .Range("b" & Rows.Count).End(xlUp)) _
        .Find("*", searchformat:=True)
        If Not r Is Nothing Then
            If r.Row > 19 Then .Rows("16:" & r.Row - 2).Delete
        End If
    End With
End Sub

Display More

Kaherdin · Mar 9th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Below the summary tables created by sub test that you coded there will always be one part static text but also more tables that other sheets will generate. These tables will have number in them that are dynamic (cell references or values comming from a userform that I have made).
The example text and example tables that are in the sheet NOW are only examples and not how it will acctually look in the end...
I cannot send you any more, and better, example files until monday because the files are at work.... sorry.
I hope that if you can figure a way around the issue of everything below B16 is being deleted when running sub test that you are willing to share your brilliant sollution with me I am very greatful for your help! Best regards from Sweden

Kaherdin · Mar 12th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

forum.ozgrid.com/index.php?attachment/44393/
The code from your post 11 works just as you describe!
It wont delete any cells below on sheet 2BPrinted, and including, the cell that has a value and the font is set to bold.
I don't eaven know if I dare to ask of you to help me out more with this sub anymore, and if you feal that you've done enough please dont answer this next question;

I am trying to understand my self how to format the cells of the generated tables but right now its a whole new world to me.
Im attaching an example of how the goal of the formatting should be.

I didnt focus on this in the beginning of this thread because I didnt even think that I would get an answer for the issue of sorting and generating new tables...

jindon · Mar 13th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

And what is your question?

jindon · Mar 13th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Ahh, I see what you mean
Change

Code

With .Range("a5") 
                         'Detta 舐 slutsumman p・varje enskilt RefNo
                        .Font.Size = 7 '<- change to suite
                        .RowHeight = 10 '<- change to suite
                        .Resize(2).Borders.Weight = 2 
                    End With

to

Code

With .Range("a5")
                         'Detta ? slutsumman pｷvarje enskilt RefNo
                        .Font.Size = 7 '<- change to suite
                        .RowHeight = 10 '<- change to suite
                        .Resize(2).BorderAround Weight:=2
                        .Offset(1).Borders(xlEdgeBottom).Weight = 3
                    End With

Kaherdin · Mar 13th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

forum.ozgrid.com/index.php?attachment/44419/Yup, that was amost all I wanted to fix!
1. Also, row 19, 26 and 33; I want to change the row height to 4.
2. Also I want to change the way the cell borders are drawn. Check attached file findandfill04, sheet 2BPrinted, and then look at how the cell borders are drawn. Is that possible to do with VBA code?

When this is done you have answerd all my questions for me!
I am very greatful for all your work!
THANK YOU! :yourock:

jindon · Mar 13th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

What do you think you are doing?

I really hate how you ask, why didn't you aks all in one?????

Kaherdin · Mar 13th 2012

Re: Find one or multiple unique numbers, create table and do sum on category for that

Because I'm new at this. Never mind then.

Find one or multiple unique numbers, create table and do sum on category for that num

Participate now!

Share