Hello,

Sometimes I got something were I think..... is this (im)possible ? :)
It's a special way of registering data, but the challange is to get the sum of the counting. A part of the challange is that de value is a part of a textcode and sometimes there are more textcodes/values registered in one cell.
In fact.... to complex for me :(
So, if somebody thinks, Yes this is nice to solve. Feel free and make me happy.

Regards, Johan



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).

The above explanation looks clear. Now the challange to solve.
Hopely....... thanks !

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

Hi Johan,

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

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

you can also try following macro and check out which of the macros works
better for your layout and your problem:

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")
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = i + 10
LRowSh1 = .Cells(.Rows.Count, z).End(xlUp).Row
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
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Windows10
Office 2016

Hello Claus, THANKS !!!!

The Code2 works well for me !.

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.

Just for sure..... There should be no limit in the amount of records and columns used. (In pratical I think the max I will use is 5000 records and till column DA).

Regards, Johan

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

Claus thanks. The skipfunction works well :)
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.
The way it works is super !
Regards, Johan

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