Hi Johan,

Am Thu, 30 May 2019 03:22:31 -0700 (PDT) schrieb JS SL:

Sheet1;

Column A/B has information not relevant for the macro.
The heading in record 5 has the persons name. For example C5=MisterX, D5=MisterY, E5=MisterZ,

This look then like

A - B - C - D - E
1
2
3
4
5 - . - MisterX - MisterY - MisterZ
6
7

Whats next :)

In the records there's a textcode written with a value between brackets.
The code is build up with points and then the brackets. So you get for example "AA.BB.CC.[50]".
Looks easy so far (?). The other challange is that in the same cell sometimes more then one code is registered splitted by using Alt-Enter. So you get in the cell for example;
"AA.BB.CC.[50]"
"DD.EE.FF.[100]"

In the other cell could be registered somethings like
"GG.HH.II.[20]"
"AA.BB.CC.[10]"

Ps. The cell could be also 'empty'.

What you see is when you combine everything you get for a specific column;
"AA.BB.CC.[50]" + "AA.BB.CC.[10]" = "AA.BB.CC.[60]"
"DD.EE.FF.[100]"
"GG.HH.II.[20]"

This is the meaning for counting !.

In Sheet2 in ColumnA all the unique used or possible to use codes are registered by me here as the basis from record 2 till last.
So you get;
A2= AA.BB.CC
A3= DD.EE.FF
A4= GG.HH.II

In Cell B2, C2, etc... the names of the persons are registered (MisterX, MisterY, etc..).

Then you get;
A1= MisterX - MisterY - MisterZ
A2= AA.BB.CC
A3= DD.EE.FF
A4= GG.HH.II

Counting; The macro should count the sum of the values in Sheet1 with the same textcode by the specific name. Then register the sum of that in the specific record with the same textcode (column.A) and person (could be Column.B, C etc..) in Sheet2.

So you get;
A1= MisterX - MisterY - MisterZ
A2= AA.BB.CC 60
A3= DD.EE.FF 100
A4= GG.HH.II 20

Another thing is that if in Sheet1 range C6:LastRow/Column a textcode is registered, as part of one of the cells, that isn't exist in Sheet2 Column.A than the specific cell in Sheet1 should colored red (this means that this cell contains a code that isn't exist).

try:

Sub SumCodes()
Dim LCol As Integer, i As Integer, n As Integer, x As Integer, z As
Integer
Dim LRowSh1 As Long, LRowSh2 As Long, j As Long
Dim varNames As Variant, varCodes As Variant, varTmp As Variant
Dim FirstAddress As String
Dim codeSum As Long
Dim c As Range

With Sheets("Sheet2")
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRowSh2 = .Cells(.Rows.Count, "G").End(xlUp).Row
varNames = .Range("H1", .Cells(1, LCol))
varCodes = .Range("G2:G" & LRowSh2)
End With
x = 2: z = 8
With Sheets("Sheet1")
For i = LBound(varNames, 2) To UBound(varNames, 2)
LRowSh1 = .Cells(.Rows.Count, i + 2).End(xlUp).Row
For j = LBound(varCodes) To UBound(varCodes)
codeSum = 0
Set c = .Range(.Cells(6, i + 10), .Cells(LRowSh1, i + 10)) _
.Find(varCodes(j, 1), lookat:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
varTmp = Split(c, Chr(10))
For n = LBound(varTmp) To UBound(varTmp)
If varTmp(n) Like varCodes(j, 1) & "*" Then
codeSum = codeSum + Left(Split(varTmp(n), "[")(1), Len(Split(varTmp(n), "[")(1)) - 1)
End If
If Application.CountIf(Sheets("Sheet2").Range("G:G"), _
Left(Split(varTmp(n), "[")(0), Len(Split(varTmp(n), "[")(0)) - 1)) = 0 Then c.Interior.Color = vbRed
Next
Set c = .Range(.Cells(6, i + 10), .Cells(LRowSh1, i + 10)).FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
If codeSum 0 Then
Sheets("Sheet2").Cells(x, z) = codeSum
End If
x = x + 1
Next
x = 2
z = z + 1
Next
End With

End Sub


Regards
Claus B.
--
Windows10
Office 2016