VBA: Using Nested Loops to expand a summarised table.

[Paddycrook]

Hi Everyone

I would like to start off by saying I am a complete newbie to VBA. I have been trying to do this for hours now and just ended up confusing myself.

As far as I can tell there needs to be a nested loop with some kind of variable inside a variable, but to be honest it's well beyond my current skill level... I thought rather than confusing everyone reading this post and embarrassing myself with my poor code, I would just put the before and after tables to simplify things. It might also be less complicated than what I thought. If anone feels like helping me out I would be very greatful

I have the file hosted on my Google Docs below.
https://docs.google.com/file/d/0B73mVtKj5WFvY0RDQzZBYTJfb0k/edit?usp=sharing

Thanks!
Paddy

Company	Item	Quantity	Costs
Tesco	Cheese	4	£50
Tesco	Milk	5	£50
Tesco	Bread	7	£50
Tesco	Butter	2	£50
Walmart	Pencils	3	£50
Walmart	Cabbages	9	£50
Walmart	Cheese	2	£50
Walmart	Balls	8	£50
Walmart	Paper	2	£50
Walmart	Meat	4	£50
Morrisons	Pens	6	£100
Morrisons	Goats Milk	9	£100
Morrisons	Crabs	5	£100
Morrisons	Apples	3	£100
Morrisons	Oranges	5	£100
Morrisons	Milk	9	£100
Morrisons	Toothpast	6	£100

<tbody>
</tbody>

to

Company	Item	Costs
Tesco	Cheese	£ 12.50
Tesco	Cheese	£ 12.50
Tesco	Cheese	£ 12.50
Tesco	Cheese	£ 12.50
Tesco	Milk	£ 10.00
Tesco	Milk	£ 10.00
Tesco	Milk	£ 10.00
Tesco	Milk	£ 10.00
Tesco	Milk	£ 10.00
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Bread	£ 7.14
Tesco	Butter	£ 25.00
Tesco	Butter	£ 25.00
Walmart	Pencils	£ 16.67
Walmart	Pencils	£ 16.67
Walmart	Pencils	£ 16.67
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cabbages	£ 5.56
Walmart	Cheese	£ 25.00
Walmart	Cheese	£ 25.00
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Balls	£ 6.25
Walmart	Paper	£ 25.00
Walmart	Paper	£ 25.00
Walmart	Meat	£ 12.50
Walmart	Meat	£ 12.50
Walmart	Meat	£ 12.50
Walmart	Meat	£ 12.50
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Pens	£ 16.67
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Goats Milk	£ 11.11
Morrisons	Crabs	£ 20.00
Morrisons	Crabs	£ 20.00
Morrisons	Crabs	£ 20.00
Morrisons	Crabs	£ 20.00
Morrisons	Crabs	£ 20.00
Morrisons	Apples	£ 33.33
Morrisons	Apples	£ 33.33
Morrisons	Apples	£ 33.33
Morrisons	Oranges	£ 20.00
Morrisons	Oranges	£ 20.00
Morrisons	Oranges	£ 20.00
Morrisons	Oranges	£ 20.00
Morrisons	Oranges	£ 20.00
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Milk	£ 11.11
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67
Morrisons	Toothpaste	£ 16.67

<tbody>
</tbody>

 

[ChrisM]

Give this code a shot. You need to highlight your desired range, including headers, then run this code. It will output the results three rows below your highlighted section (and will overwrite anything there)

Sub test()

Dim rRange As Range
Dim rOutput As Range
Dim lRows As Long
Dim aTemp As Variant
Dim i As Long, k As Long
Dim sCurrCo As String
Dim lcount As Long
Dim dCurrCost As Double

Set rRange = Selection 'A1:Dxxx

lRows = Application.WorksheetFunction.Sum(rRange.Resize(, 1).Offset(1, 2))

ReDim aTemp(1 To lRows + 1, 1 To 3)

aTemp(1, 1) = rRange.Range("A1") 'write headers
aTemp(1, 2) = rRange.Range("B1")
aTemp(1, 3) = rRange.Range("D1")

lcount = 2
For i = 2 To rRange.Rows.Count
    dCurrCost = rRange.Cells(i, 4) / rRange.Cells(i, 3)
    For k = 1 To rRange.Cells(i, 3)
        aTemp(lcount, 1) = rRange.Cells(i, 1) 'company
        aTemp(lcount, 2) = rRange.Cells(i, 2) 'item
        aTemp(lcount, 3) = dCurrCost 'cost per
        lcount = lcount + 1
    Next k
Next i

'now write array to sheet, 3 rows below source range
Selection.Resize(1, 1).Offset(rRange.Rows.Count + 3, 0).Resize(lRows + 1, 3) = aTemp 'this is really ugly!!

Set rOutput = Nothing
Set rRange = Nothing

End Sub

 

[ChrisM]

I should have read the range in to an array, I don't know why I read it into a Range object, I was thinking along different lines at the beginning I guess. Oh well, it still works fine.

 

[Paddycrook]

Thanks! I have no clue how this works but it does Will probably do a bit of homework just working out the hows and whys of it. Really great stuff though - much appreciated!