Hi Johan,

Am Thu, 30 May 2019 12:06:09 -0700 (PDT) schrieb JS SL:


A few remarks that perhaps you can solve in it.
1) If a specific column has no data in at least one of the records below, then the macro stops with an error.
It seems that an empty column is not skipped from the code (no data in record 6 till last used).
2) If a specific column has only data in record 6, then te macro stops with an error.
It seems that the code looks from record 7 and further instead of record 6 and further.

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 + 10
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 - 3) = codeSum
Next
Skip:
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Windows10
Office 2016