Hi Johan,

Am Thu, 30 May 2019 21:54:45 -0700 (PDT) schrieb JS SL:

Whats the trick in the code that I can't find/understand when I also want to include a column in Sheet2. Instead of the TextCode now it is in Column G it moves to Column H. I see the needed changes were "G" is wrote and I have to change it in "H" but.... still the results came on the same place (just column G).
Can you please change the requered part(s) so I can also see where the hidden trick is :)

the columns with the names in it now are determined automatically.
When codes are moved there are 3 lines to change. I put in comments for
these lines:

Sub SumCodes2()
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
'Modify the range when codes are moved
varCodes = .Range("H2:H" & LRowSh2)
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 = Left(Split(rngC, "[")(1), Len(Split(rngC, "[")(1)) - 1)
'Modify the range when codes are moved
If Application.CountIf(Sheets("Sheet2").Range("H:H"), 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 = Left(Split(varTmp(n), "[")(1), Len(Split(varTmp(n), "[")(1)) - 1)
'Modify the range when codes are moved
If Application.CountIf(Sheets("Sheet2").Range("H:H"), 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