View Single Post
  #16   Report Post  
Posted to microsoft.public.excel.programming
JS SL JS SL is offline
external usenet poster
 
Posts: 49
Default Count the sum of multiply values in one cell, registered as partof a textcode, combine them per column and show the results in the next sheet

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