Solved: Merge cells into one if value is smaller than...

[LinkND]

I don't know if it's possible, but maybe someone knows how to do it.

I made a program to filter unique companies (column A) from another sheet and count the total ammount (column B) of each of them. In column C I am calculating the % of the total.

The code below is only a part of the code I already have. What I want to try is finding all the companies with a total of 4% or below and put them together into a new cell called 'leftovers'. Merging the small ones will be more efficient if I want to create a chart later on for my report.

If I am just calculating them with a formula, it's easy to find the total ammount of all the companies with a smaller value than my constant of 4%: =SUMIF(C3:C11;"<0,04"), with C3:C11 as my range. I made a dummy file with test data to give you an impression of my own file/sheet.

Sub ProcessCompanies()

Dim LastRow As Long
Dim MyRng As Range
Dim yCell As Range

Application.ScreenUpdating = False

With Sheets("CompanyTotals")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set MyRng = Range(Cells(1, "B"), Cells(LastRow, "B"))
For Each yCell In MyRng
yCell.Select
Selection.FormulaArray = "=COUNTIF(CompanyNames!C[33],RC[-1])"
Next yCell
Set MyRng = Range(Cells(1, "C"), Cells(LastRow, "C"))
For Each yCell In MyRng
yCell.Select
Selection.FormulaArray = "=RC[-1]/(SUM(C[-1]))"
Next yCell
End With

Application.ScreenUpdating = True

End Sub

[mdmackillop]

Option Explicit
Sub Test()
Dim Rng As Range
Dim i As Long
Set Rng = Cells(Rows.Count, 1).End(xlUp).Offset(1)
With Rng
.Offset(-1).Resize(, 3).Copy
.PasteSpecial Paste:=xlFormats
.Formula = "Leftovers (companies with a % < 4):"
.Offset(, 2).FormulaR1C1 = "=RC[-1]/sum(C2)"
For i = .Row - 1 To 3 Step -1
If Cells(i, 3) < 0.04 Then
.Offset(, 1) = .Offset(, 1) + Cells(i, 2)
Cells(i, 1).Resize(, 3).Delete Shift:=xlUp
End If
Next
End With
End Sub

[LinkND]

Hey thanks mdmackillop ^^ this code really does the stuff! I checked it out in my master file and everything went like I wanted.

Nice job and keep up the good work :D