Hi again,

Am Fri, 7 Nov 2014 09:01:49 +0100 schrieb Claus Busch:

try:

Sub MultiSum()

here now with some comments and Application.Screenupdating:

Sub MultiSum()
Dim LRow As Long, i As Long
Dim mySum As Double, Total As Double
Dim strFormat As String

Application.ScreenUpdating = False
With ActiveSheet
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Insert rows when value in A changes
For i = LRow To 2 Step -1
If .Cells(i, 1) < .Cells(i + 1, 1) Then
.Rows(i + 1).Insert
End If
Next
'Calculating the sum of each item
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LRow + 1
If Len(.Cells(i, 1)) = 0 Then
.Cells(i, 3) = .Cells(i - 1, 1) & "tot = " & mySum
mySum = 0
i = i + 1
End If
If i LRow + 1 Then Exit For
'Picks the numbers on the right side of the string and add them
mySum = mySum + CDbl(Mid(.Cells(i, 2), _
InStrRev(.Cells(i, 2), " ") + 1))
'Is calulating the total of all items
Total = Total + CDbl(Mid(.Cells(i, 2), _
InStrRev(.Cells(i, 2), " ") + 1))
Next
'Calculating the % for each total
For i = 2 To LRow + 1
If Len(.Cells(i, 3)) 0 Then
.Cells(i, 4) = Mid(.Cells(i, 3), InStrRev(.Cells(i, 3), " ") +
1) / Total
.Cells(i, 4).NumberFormat = "0.00%"
End If
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional