Error Handler
I think the problem lies more with my poor coding than Excel.
Before this sheet breaks down it is suppose to create a sheet, and paste
data from another sheet using location data.
The problem lies in something to do with that I have 19 seperate pieces of
code. Rather than one standard that is repeated 19 times with the basic
information (section number changing).
Sub Section_1()
'
' Macro1 Macro
' Macro recorded 17/08/2004 by David Trevelyan
'
'
' Error Handler
On Error GoTo Handler
' Add Section Sheets and name it
Windows("Quotation.xls").Activate
Sheets.Add
ActiveSheet.Name = "Section 1"
Sheets(Application.ActiveSheet.Name).Move After:=Sheets(Sheets.Count)
' Find and copy data from finalised data sheet
Windows("Finalised update information.xls").Activate
Application.Goto Reference:="Sec1" <---- Named range from sheet to be
pasted from
Selection.Copy
' Paste data into section 1 sheet
Windows("Quotation.xls").Activate
Sheets("Section 1").Select
Range("A7").Select
ActiveSheet.Paste
Columns("E:G").EntireColumn.AutoFit
Columns("A:D").Select
Selection.EntireColumn.Hidden = True
' Paste in section data and set format
Workbooks.Open Filename:= _
"\\Wtbnas1\Shared Data\Commercial Services\11. DHT\05 Linked
Updates\Files\Unison Categories.xls"
Windows("Quotation.xls").Activate
Range("E6").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(""CDU Page "",R[1]C[-1],"" -
"",VLOOKUP(R[1]C[-4],'[Unison Categories.xls]Sheet1'!C1:C7,5,FALSE),""
"",VLOOKUP(R[1]C[-4],'[Unison Categories.xls]Sheet1'!C1:C7,6,FALSE),""
"",VLOOKUP(R[1]C[-4],'[Unison Categories.xls]Sheet1'!C1:C7,7,FALSE))"
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
' Insert Nett discounted price column
Range("H7").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-(RC[-1]/100*RC[1])"
Set rng = Selection(1, 1)
Set rng1 = Intersect(rng.CurrentRegion, Columns(rng.Column))
crTopRow = rng1.Rows(1).Row
Set rng1 = rng1.Offset(rng.Row - crTopRow, 0). _
Resize(rng1.Rows.Count - (rng.Row - crTopRow))
If rng1.Count 1 Then
Selection.AutoFill rng1
End If
' Insert Discount % column
Range("I7").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-8],Terms2,5,FALSE)),0,VLOOKUP(RC[-8],Terms2,5,FALSE
))"
Set rng = Selection(1, 1)
Set rng1 = Intersect(rng.CurrentRegion, Columns(rng.Column))
crTopRow = rng1.Rows(1).Row
Set rng1 = rng1.Offset(rng.Row - crTopRow, 0). _
Resize(rng1.Rows.Count - (rng.Row - crTopRow))
If rng1.Count 1 Then
Selection.AutoFill rng1
End If
' Format columns and autofit width
Columns("G:I").Select
Selection.NumberFormat = "0.00"
Range("G6").Select
ActiveCell.FormulaR1C1 = "List Price"
Range("H6").Select
ActiveCell.FormulaR1C1 = "Nett Price"
Range("I6").Select
ActiveCell.FormulaR1C1 = "% Discount"
Range("G6:I6").Select
Selection.Font.Bold = True
Columns("G:I").Select
Columns("G:I").EntireColumn.AutoFit
Range("A7").Select
' Insert header row at new item
col = ActiveCell.Column
lastrow = Cells(Rows.Count, col).End(xlUp).Row
If IsEmpty(Cells(1, col).Value) Then
firstrow = Cells(1, col).End(xlDown).Row
Else
firstrow = 1
End If
Set Cell = Cells(lastrow, col)
While Cell.Row firstrow + 6
If Cell.Value < Cell.Offset(-1, 0).Value Then
' When change found insert heading and make bold and size 12
Cell.EntireRow.Insert
Cells(Cell.Row - 1, "E").NumberFormat = "General"
Cells(Cell.Row - 1, "E").Value = "=CONCATENATE(""CDU Page
"",R[1]C[-1],"" - "",VLOOKUP(R[1]C[-4],'[Unison
Categories.xls]Sheet1'!C1:C7,5,FALSE),"" "",VLOOKUP(R[1]C[-4],'[Unison
Categories.xls]Sheet1'!C1:C7,6,FALSE),"" "",VLOOKUP(R[1]C[-4],'[Unison
Categories.xls]Sheet1'!C1:C7,7,FALSE))"
Cells(Cell.Row - 1, "E").Font.Bold = True
With Cells(Cell.Row - 1, "E").Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Set Cell = Cell.Offset(-2, 0)
Else
Set Cell = Cell.Offset(-1, 0)
End If
Wend
' removes the equations
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
' Formats the page
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range("G6").Select
ActiveSheet.Pictures.Insert( _
"\\Wtbnas1\Shared Data\Commercial Services\11. DHT\05 Linked
Updates\Files\Burdens.jpg" _ 'network location
).Select
Selection.ShapeRange.IncrementLeft 14.25
Selection.ShapeRange.IncrementTop -58.5
' Set resting location on page
Range("A7").Select
Exit Sub
Handler:
????
End Sub
This code is run from another macro. which application.run"Section_1" is
used.
What I don't know what to do is tell VBA to create sheets 1 - 19 using the
prefix of 1 to 19 create sheets relating to this.
I'm sure this is possible but I haven't got a clue where to start!
Thanks for your help.
Dave
"Auric__" wrote in message
...
On Wed, 18 Aug 2004 16:47:01 +0100, dht wrote:
I have tried this and it doesn't appear to work I'm using Excel 2000 if
this
helps.
Dave
So am I. Here's what I used; works just fine for me (modified a bit for
my system):
Sub Section_1()
On Error GoTo Handler
'...code...
Exit Sub
Handler:
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range("G6").Select
ActiveSheet.Pictures.Insert _
("c:\documents and settings\auric\desktop\223.jpg").Select
Selection.ShapeRange.IncrementLeft 14.25
Selection.ShapeRange.IncrementTop -58.5
End Sub
I just noticed that your picture seems to have an invalid path. You have
"\\\files etc pics \logo.jpg" as the path; there should not be three
backslashes, either one or two. I imagine that's a relative path, right?
(As opposed to another computer on the network.) Also, "files etc pics"
probably doesn't end with a space. Try changing it to "\\files etc
pics\logo.jpg" or "\files etc pics\logo.jpg" or even
"\files\etc\pics\logo.jpg" and see what happens.
--
auric underscore underscore at hotmail dot com
*****
What? Boo is outraged! See his fury! It's small, so look close. Trust
me, it's there.
|