Hi Johan,

Am Thu, 30 May 2019 13:42:47 -0700 (PDT) schrieb JS SL:

One thing I could not find/solve. When I insert in Sheet1 new columns from J till Z (that means that the actual column J moves to column AA) then in Sheet2 the first columns give no results and the other ones shows the results correctly.
Is there something in the code that block me to de that.
Or better... could you change the code in such a way that in sheet1 I start with the textcodes from column AA.

if you insert columns you must modify "z" and the column in the output
cell
Try:

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

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

Application.ScreenUpdating = False

With Sheets("Sheet1")
LRowSh1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = i + 26
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)
If Application.CountIf(Sheets("Sheet2").Range("G:G"), 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)
If Application.CountIf(Sheets("Sheet2").Range("G:G"), 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, z - 19) = codeSum
Next
Skip:
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Windows10
Office 2016