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

Claus, Thanks (again!).

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

regards, Johan
(and many many thanks)

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

Thanks Claus.
Now it's clear when inserting in Sheet2 a column resulting in moving the TextCodes to another column, but..... Now I'm strugling with understanding the startpoint in Sheet1.

In one of the first codes it was;
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = i + 10
So, because I inserted also some columns in Sheet1 it was easy understanding to change i+10 to i+26 because I change the startingpoint to column AA.

You have change this part of the code to
LColSh1 = .Cells(5, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(5, LColSh1))

So I thought I have to change it to
LColSh1 = .Cells(27, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(27, LColSh1))

Oeps..... didn't work. In the normal situation and even when I had change it it gave the error on code record;
iNmbr = Left(Split(rngC, "[")(1), Len(Split(rngC, "[")(1)) - 1)

I need the helpdesk (again).

In fact;
Sheet1 headings are in row 5, a general always filled column is A, the columns with the textcodes starts in column AA end will be end at max in the future 100 columns further
Sheet2 headings are in row 1, a general always filled column is A, the columns with the counting of the textcodes from sheet1 starts in column H (and ended with data in the furture at max H+100).

HELP :)
Perhaps its easy to solve, but... I can't see the trick (early in the morning).

regards, Johan

Hi Johan,

Am Fri, 31 May 2019 22:35:37 -0700 (PDT) schrieb JS SL:

In one of the first codes it was;
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = i + 10
So, because I inserted also some columns in Sheet1 it was easy understanding to change i+10 to i+26 because I change the startingpoint to column AA.

You have change this part of the code to
LColSh1 = .Cells(5, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(5, LColSh1))

So I thought I have to change it to
LColSh1 = .Cells(27, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(27, LColSh1))

when you insert columns the new ranges will be calculated automatically.
The only thing you must change in the code is the range for the codes
when this range has changed.
Make some test without changing the range for the codes. Insert or
delete columns in both sheets and you will see that the output is always
correct.


Regards
Claus B.
--
Windows10
Office 2016

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

Whats the problem here ?

regards, Johan

Hi Johan,

Am Fri, 31 May 2019 22:35:37 -0700 (PDT) schrieb JS SL:

In one of the first codes it was;
For i = LBound(varNames, 2) To UBound(varNames, 2)
z = i + 10
So, because I inserted also some columns in Sheet1 it was easy understanding
to change i+10 to i+26 because I change the startingpoint to column AA.

You have change this part of the code to
LColSh1 = .Cells(5, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(5, LColSh1))

So I thought I have to change it to
LColSh1 = .Cells(27, .Columns.Count).End(xlToLeft).Column
varNames = .Range(.Cells(5, firstSh1), .Cells(27, LColSh1))

when you insert columns the new ranges will be calculated automatically.
The only thing you must change in the code is the range for the codes
when this range has changed.
Make some test without changing the range for the codes. Insert or
delete columns in both sheets and you will see that the output is always
correct.


Regards
Claus B.

Claus,
Using Defined Names for various ranges eliminates the problems associated with
range addresses changing when inserting/deleting cols/rows, AND eliminates the
need for code updating as a result!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

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

Hi Garry,

Am Sat, 01 Jun 2019 04:06:50 -0400 schrieb GS:

Using Defined Names for various ranges eliminates the problems associated with
range addresses changing when inserting/deleting cols/rows, AND eliminates the
need for code updating as a result!

you are right. I changed it.


Regards
Claus B.
--
Windows10
Office 2016

Claus, Garry,
Thanks both. It works super. The trick is that for row.5 the cells in the same row before the startcolumn should be empty. That's oke for me.
The other attention comes from Claus is to set a RangeName in Sheet.2 at the TextCode column (in this case column H).
Herewith the final and working code from Claus.
THANKS !! Claus you are great !!!

regards, Johan.
--------------------------------------------------------------------

Sub SumCodes3()
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

Application.ScreenUpdating = False

With Sheets("Count") 'Count = Sheet1
LColSh2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRowSh2 = .Cells(.Rows.Count, "A").End(xlUp).Row
varCodes = Range("Codes") 'Codes is a RangeName in Sheet2 at the column of the TextCodes, for example Column.H, with name "Codes" and formula "=OFFSET(Sheet2!$H$2,,,COUNTA(Sheet2!$H:$H)-1)"
End With

With Sheets("Planning") '=Sheet2
LRowSh1 = .Cells(.Rows.Count, "A").End(xlUp).Row
'first col with a name. The hading starts in row 5. The rowcells before the to use column should be empty !
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("Count").Cells(x, LColSh2 - UBound(varNames, 2) + i) = codeSum
Next
Skip:
Next
End With

End Sub

you are right. I changed it.

Nicely done!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Claus,

ManyMany thanks the way you helped me out.

And just as with a nice diner.....there's sometimes the need for a nice dessert. In my case the dessert is the count of the cost based on the values for the headingnames in sheet.2 were for those names in sheet.3 a costvalue is registered (sheet.3 column.B is the name and column.D the cost).

Sheet.3; For Mister.X the value 50 is registered and for Mister.Y 100

What's nice to have (the dessert);

ps. In sheet.2 I had moved the column with the TextCodes to column.M.

In sheet.2 in column.J (perhaps you can give it the RangeName 'cost' so it can flow when inserting/deleting columns), I like to have the sum of the values for each column in the same row.

What you get is; Mister.X = value 10 - multiply with 50 from sheet.3 = 500. In the same record stands Mister.Y = value 6 - multiply with the value 100 in sheet.3 = 600.

This gives the sum of 500+600=1100. This should be then the value in column.J of that record in sheet.2.

If..... the name in sheet.2 isn't exist in sheet.3 column.B then, if there is a value registered in sheet.2, the cell should be marked red.

Another exception.... this count rule must only count if the last 2 digits of that record in sheet.2 column.M (thats the famous 'codes' RangeName) is "HR".


Is this a nice dessert or not. It should be great if I can enjoy this !! :)
ps. If easier you can make it a separate code to run.

And.... Thanks if possible to do (!)

Hi Johan,

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

Sheet.3; For Mister.X the value 50 is registered and for Mister.Y 100

In sheet.2 in column.J (perhaps you can give it the RangeName 'cost' so it can flow when inserting/deleting columns), I like to have the sum of the values for each column in the same row.

What you get is; Mister.X = value 10 - multiply with 50 from sheet.3 = 500. In the same record stands Mister.Y = value 6 - multiply with the value 100 in sheet.3 = 600.

This gives the sum of 500+600=1100. This should be then the value in column.J of that record in sheet.2.

If..... the name in sheet.2 isn't exist in sheet.3 column.B then, if there is a value registered in sheet.2, the cell should be marked red.

Another exception.... this count rule must only count if the last 2 digits of that record in sheet.2 column.M (thats the famous 'codes' RangeName) is "HR".

that is easier and faster when you do it with formulas and conditional
formatting.


Regards
Claus B.
--
Windows10
Office 2016

Claus,

The way you suggest with the formula;
=IF(RIGHT(M2,2)<"HR","",SUMIF(myNames,N$1,Cost)*N 2+SUMIF(myNames,O$1,Cost)*O2+SUMIF(myNames,P$1,Cos t)*P2+SUMIF(myNames,Q$1,Cost)*Q2)

And NameRanges in Sheet.3 for the names and the cost, and also a ConditionalFormatting in Sheet.2, works fine.

Thnk !!!. And now playing with the tool created.

regards, Johan