Hi Johan,

Am Sat, 1 Jun 2019 00:30:16 -0700 (PDT) schrieb JS SL:

Oke, so.... if I understand it correctly then the only thing I had to change is the Sheet2 column were the TextCode is registered. This is at this moment column H. Just as you remarked clear in the code.
In Sheet1 its no issue that the TextCodes are registered in column AA and so further on. Oke.

Then it should work, but.. the code still gives an error on below last rule;

For i = LBound(varNames, 2) To UBound(varNames, 2)
z = firstSh1 - 1 + i
If Application.CountA(.Range(.Cells(6, z), .Cells(LRowSh1, z))) = 0 Then GoTo Skip
For j = LBound(varCodes) To UBound(varCodes)
x = j + 1
codeSum = 0
For Each rngC In .Range(.Cells(6, z), .Cells(LRowSh1, z)).SpecialCells(xlCellTypeConstants)
If InStr(rngC, Chr(10)) = 0 Then
sCode = Left(Split(rngC, "[")(0), Len(Split(rngC, "[")(0)) - 1)
iNmbr = Left(Split(rngC, "[")(1), Len(Split(rngC, "[")(1)) - 1)

The last rule gives the error (iNmbr....).

for me it works fine. I supposed that in Sheet1 row 5 the first entry is
one of the names. If you have other entries in row 5 in front of the
names you have to change the line with Application.Match to the first
name instead of "*"
Now I have created a range name for the codes. You can insert or delete
columns without changing the code:

Sub SumCodes()
Dim LColSh1 As Integer, LColSh2 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 codeSum As Long
Dim rngC As Range
Dim sCode As String, iNmbr As Integer, firstSh1 As Integer

With Sheets("Sheet2")
LColSh2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRowSh2 = .Cells(.Rows.Count, "A").End(xlUp).Row
varCodes = Range("Codes")
End With

Application.ScreenUpdating = False

With Sheets("Sheet1")
LRowSh1 = .Cells(.Rows.Count, "A").End(xlUp).Row
'first col with a name
firstSh1 = Application.Match("*", .Range("5:5"), 0)
LColSh1 = .Cells(5, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(5, LColSh1))
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = firstSh1 - 1 + i
If Application.CountA(.Range(.Cells(6, z), .Cells(LRowSh1, z))) = 0 Then GoTo Skip
For j = LBound(varCodes) To UBound(varCodes)
x = j + 1
codeSum = 0
For Each rngC In .Range(.Cells(6, z), .Cells(LRowSh1, z)).SpecialCells(xlCellTypeConstants)
If InStr(rngC, Chr(10)) = 0 Then
sCode = Left(Split(rngC, "[")(0), Len(Split(rngC, "[")(0)) - 1)
iNmbr = CInt(Left(Split(rngC, "[")(1), Len(Split(rngC, "[")(1)) - 1))
If Application.CountIf(Range("Codes"), sCode) = 0 Then
rngC.Interior.Color = vbRed
ElseIf sCode Like varCodes(j, 1) & "*" Then
codeSum = codeSum + iNmbr
End If
Else
varTmp = Split(rngC, Chr(10))
For n = LBound(varTmp) To UBound(varTmp)
sCode = Left(Split(varTmp(n), "[")(0), Len(Split(varTmp(n), "[")(0)) - 1)
iNmbr = CInt(Left(Split(varTmp(n), "[")(1), Len(Split(varTmp(n), "[")(1)) - 1))
If Application.CountIf(Range("Codes"), sCode) = 0 Then
rngC.Interior.Color = vbRed
ElseIf sCode Like varCodes(j, 1) & "*" Then
codeSum = codeSum + iNmbr
End If
Next
End If
Next
If codeSum 0 Then Sheets("Sheet2").Cells(x, LColSh2 - UBound(varNames, 2) + i) = codeSum
Next
Skip:
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Windows10
Office 2016