Hi, i got this code very kindly from Tom and i have changed it, but it
does not work. Could you please help me ?

Sub TotalsS()
'
Dim eRowS As Long
Dim fRowS As Long
Dim LrowS As Long
Dim myValS As Long
eRowS = Cells(Rows.Count, 1).End(xlUp).Row
fRowS = 4
Do Until LrowS = eRowS + 1
LrowS = Cells(fRowS, 10).End(xlDown).Row + 1
With Cells(LrowS, 10)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "R #,##0.00"
.FormulaR1C1 = _
"=SUM(R[-" & LrowS - fRowS & "]C:R[-1]C)"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
End With
End With
fRowS = LrowS + 2
Loop
myValS = Cells(LrowS, 10)
With Cells(LrowS, 10)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlGreater, Formula1:="0"
.FormatConditions(1).Interior.ColorIndex = 35
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlLess, Formula1:="0"
.FormatConditions(2).Interior.ColorIndex = 38
End With
If myValS < 0 Then Cells(LrowS, 7) = "Total due to supplier"
'--Minus value
If myValS 0 Then Cells(LrowS, 7) = "Total due to BMW SA" '
--Positive value
With Cells(LrowS, 7)
.Font.Bold = True
End With
Columns("J:J").ColumnWidth = 12
Range("C4").Select
ActiveWindow.FreezePanes = True
GetSuppNameAS
End Sub


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Um? What does not work? What errors do you get and what is it trying to do
?

--
Cheers
Nigel



"Les Stout" wrote in message
...
Hi, i got this code very kindly from Tom and i have changed it, but it
does not work. Could you please help me ?

Sub TotalsS()
'
Dim eRowS As Long
Dim fRowS As Long
Dim LrowS As Long
Dim myValS As Long
eRowS = Cells(Rows.Count, 1).End(xlUp).Row
fRowS = 4
Do Until LrowS = eRowS + 1
LrowS = Cells(fRowS, 10).End(xlDown).Row + 1
With Cells(LrowS, 10)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "R #,##0.00"
.FormulaR1C1 = _
"=SUM(R[-" & LrowS - fRowS & "]C:R[-1]C)"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
End With
End With
fRowS = LrowS + 2
Loop
myValS = Cells(LrowS, 10)
With Cells(LrowS, 10)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlGreater, Formula1:="0"
.FormatConditions(1).Interior.ColorIndex = 35
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlLess, Formula1:="0"
.FormatConditions(2).Interior.ColorIndex = 38
End With
If myValS < 0 Then Cells(LrowS, 7) = "Total due to supplier"
'--Minus value
If myValS 0 Then Cells(LrowS, 7) = "Total due to BMW SA" '
--Positive value
With Cells(LrowS, 7)
.Font.Bold = True
End With
Columns("J:J").ColumnWidth = 12
Range("C4").Select
ActiveWindow.FreezePanes = True
GetSuppNameAS
End Sub


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Ooops...... sorry, forgot that part !!! It is almost like it is looping
as i get two totals at the bottom and i am supposed to only have one
total. I then get an error at what looks like the third loop of "out of
range" at this point: With Cells(LrowS, 10)


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

This puts in a single total at the bottom of a column of numbers starting in
Row 4 of column 10

by the way, you said "Tom" gave you this code, but it must be a different
"Tom" than me. I only mention that because you contacted me asking for
help.

Sub TotalsS()
'
Dim eRowS As Long
Dim fRowS As Long
Dim LrowS As Long
Dim myValS As Long
eRowS = Cells(Rows.Count, 1).End(xlUp).Row
fRowS = 4
LrowS = Cells(fRowS, 10).End(xlDown).Row + 1
With Cells(LrowS, 10)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "R #,##0.00"
.FormulaR1C1 = _
"=SUM(R[-" & LrowS - fRowS & "]C:R[-1]C)"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
End With
End With
fRowS = LrowS + 2
myValS = Cells(LrowS, 10)
With Cells(LrowS, 10)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlGreater, Formula1:="0"
.FormatConditions(1).Interior.ColorIndex = 35
.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlLess, Formula1:="0"
.FormatConditions(2).Interior.ColorIndex = 38
End With
If myValS < 0 Then Cells(LrowS, 7) = _
"Total due to supplier" '--Minus value
If myValS 0 Then Cells(LrowS, 7) = _
"Total due to BMW SA" '--Positive value
With Cells(LrowS, 7)
.Font.Bold = True
End With
Columns("J:J").ColumnWidth = 12
Range("C4").Select
ActiveWindow.FreezePanes = True
GetSuppNameAS
End Sub

--
Regards,
Tom Ogilvy


"Les Stout" wrote in message
...
Ooops...... sorry, forgot that part !!! It is almost like it is looping
as i get two totals at the bottom and i am supposed to only have one
total. I then get an error at what looks like the third loop of "out of
range" at this point: With Cells(LrowS, 10)


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Thanks for your help Tom, i thought it was you.

Thanks again for your help.

best regards,

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Hi Tom, i still have a problem and i cannot figure out what it is ? If i
run this code manually using "F8" to step into and then "F5" it works
great, but if i run it whith the rest of my code it inserts two totals,
one at the botom of the column and then another after it ??

Any suggestions ?

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

That would mean your other code is running it more than once.

You have to figure out why. Adding a msgbox will show you when it gets
called. Perhaps that will help.

Sub TotalsS()
'
Dim eRowS As Long
Dim fRowS As Long
Dim LrowS As Long
Dim myValS As Long

msgbox "In TotalsS"

eRowS = Cells(Rows.Count, 1).End(xlUp).Row
fRowS = 4
LrowS = Cells(fRowS, 10).End(xlDown).Row + 1
With Cells(LrowS, 10)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "R #,##0.00"
.FormulaR1C1 = _
"=SUM(R[-" & LrowS - fRowS & "]C:R[-1]C)"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
End With
End With
fRowS = LrowS + 2
myValS = Cells(LrowS, 10)
With Cells(LrowS, 10)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlGreater, Formula1:="0"
.FormatConditions(1).Interior.ColorIndex = 35
.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlLess, Formula1:="0"
.FormatConditions(2).Interior.ColorIndex = 38
End With
If myValS < 0 Then Cells(LrowS, 7) = _
"Total due to supplier" '--Minus value
If myValS 0 Then Cells(LrowS, 7) = _
"Total due to BMW SA" '--Positive value
With Cells(LrowS, 7)
.Font.Bold = True
End With
Columns("J:J").ColumnWidth = 12
Range("C4").Select
ActiveWindow.FreezePanes = True
GetSuppNameAS
End Sub


--
Regards,
Tom Ogilvy


"Les Stout" wrote in message
...
Hi Tom, i still have a problem and i cannot figure out what it is ? If i
run this code manually using "F8" to step into and then "F5" it works
great, but if i run it whith the rest of my code it inserts two totals,
one at the botom of the column and then another after it ??

Any suggestions ?

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Hi Tom, yes the addition of the msgbox does show that it is looping
again.
It would appear that the code below is the problem, but i do not know
how.

Sub BBBS()
InsertProc
Application.OnTime Now, "BBB_2S"
End Sub

Sub BBB_2S()
Application.EnableEvents = False
Columns("H:H").Locked = False ' ---This line
ActiveSheet.Protect Password:="secret", Scenarios:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Application.EnableEvents = True
SaveFileS
End Sub
Sub InsertProc()
Dim sname As String
Dim StartLine As Long
sname = ActiveSheet.CodeName
With ActiveWorkbook.VBProject.VBComponents(sname).CodeM odule
StartLine = .CreateEventProc("Change", "Worksheet") + 1
.InsertLines StartLine, _
"Dim VRange As Range"
.InsertLines StartLine + 1, _
"Set VRange =ActiveSheet.Columns(""H:H"")"
.InsertLines StartLine + 2, _
"Me.Protect UserInterfaceOnly:=True," & _
" Password:=""secret"""
.InsertLines StartLine + 3, _
"Target.Font.ColorIndex = 3"
.InsertLines StartLine + 4, _
"Target.Font.Bold = True"
End With
End Sub

Best Regards,

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

I don't see anything in that code that would cause TotalsS to run.

Columns("H:H").Locked = False ' ---This line

I don't know of any way that line would trigger code to run.

the last line of your TotalsS routine calls another procedu
GetSuppNameAS

there is a place to look as well.

--
Regards,
Tom Ogilvy


"Les Stout" wrote in message
...
Hi Tom, yes the addition of the msgbox does show that it is looping
again.
It would appear that the code below is the problem, but i do not know
how.

Sub BBBS()
InsertProc
Application.OnTime Now, "BBB_2S"
End Sub

Sub BBB_2S()
Application.EnableEvents = False
Columns("H:H").Locked = False ' ---This line
ActiveSheet.Protect Password:="secret", Scenarios:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Application.EnableEvents = True
SaveFileS
End Sub
Sub InsertProc()
Dim sname As String
Dim StartLine As Long
sname = ActiveSheet.CodeName
With ActiveWorkbook.VBProject.VBComponents(sname).CodeM odule
StartLine = .CreateEventProc("Change", "Worksheet") + 1
.InsertLines StartLine, _
"Dim VRange As Range"
.InsertLines StartLine + 1, _
"Set VRange =ActiveSheet.Columns(""H:H"")"
.InsertLines StartLine + 2, _
"Me.Protect UserInterfaceOnly:=True," & _
" Password:=""secret"""
.InsertLines StartLine + 3, _
"Target.Font.ColorIndex = 3"
.InsertLines StartLine + 4, _
"Target.Font.Bold = True"
End With
End Sub

Best Regards,

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Hi Tom, if i leave out the Insert "ProcRoutine" it works fine ? ( All of
the last code i gave)


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

I know, you told me that. I don't see any linkage.

--
Regards,
Tom Ogilvy


"Les Stout" wrote in message
...
Hi Tom, if i leave out the Insert "ProcRoutine" it works fine ? ( All of
the last code i gave)


Les Stout

*** Sent via Developersdex http://www.developersdex.com ***

Ok thanks for the help , i'm off home...

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***