C
Code Numpty
I have code in 2 modules as below. In some instances the last action deleting
the modules is not happening.
*****Module 3
Sub Quote_Wrapup()
'To stop screen flicker
Application.ScreenUpdating = False
ThisWorkBook.Activate
Sheet1.Range("quote_date") = Sheet1.Range("quote_date").Value
Sheet1.Range("qdata5,qdata6").Font.ColorIndex = 2
'To delete delivery address lines if 1st line empty
If IsEmpty(Range("deliver_line1")) _
Then Sheets(1).Range("deliver_rows").EntireRow.Delete
'No End If required as only one action as a result of the If
Sheet1.Range("Item_Nos").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheet1.Range("content") = Sheet1.Range("content").Value
Call NoDVinputMsg
Sheet1.Shapes("Group 31").Delete
Sheet1.Rows("1:1").Delete Shift:=xlUp
Sheet1.Shapes("Picture 14").Delete
Sheet1.Range("A:G").Interior.ColorIndex = xlNone
'Desperately trying to speed up delete column E!
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheet1.Range("base_p").Delete Shift:=xlToLeft
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Sheet1.Range("comm_disclines").Delete Shift:=xlUp
Sheet1.Range("boxes").Borders.LineStyle = x1None
Sheet1.Range("delterms_box").ClearContents
Sheet2.Name = "Terms&Conditions"
Sheet2.Range("instructions").Delete
Sheet2.Shapes("Picture 1").Delete
Sheet1.Range("qdata1").Select
Dim vbCom As Object
Call logquote
Application.ScreenUpdating = True
Sheet1.Range("A1:F1").HorizontalAlignment = xlCenter
Sheet1.Range("A1:F1").VerticalAlignment = xlCenter
Sheet1.Range("A1:F1").MergeCells = True
On Error Resume Next
Set vbCom = ActiveWorkbook.VBProject.VBComponents
vbCom.Remove VBComponent:= _
vbCom.Item("Module3")
vbCom.Remove VBComponent:= _
vbCom.Item("Module4")
On Error GoTo 0
End Sub
*****Module 4
ub NoDVinputMsg()
Dim rng As Range, cel As Range
Set rng = Nothing ' only if rng previously set
On Error Resume Next
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllValidation)
If Not rng Is Nothing Then
bDummy = rng.Validation.ShowInput
If Err.Number = 0 Then
' all same type, no need to loop
With rng.Validation
..InputTitle = ""
..InputMessage = ""
End With
Else
On Error GoTo 0
For Each cel In rng
With cel.Validation
..InputTitle = ""
..InputMessage = ""
End With
Next
End If
End If
End Sub
Sub logquote()
'
' logquote Macro
' Macro recorded 15/06/2007 by Sharon
'
'
Dim ThisWorkBook As String
Dim SheetName As String
Dim MyRanges(8) As String
Dim EmptyRow As Integer
Dim a As Integer 'to cyle through ranges
ThisWorkBook = ActiveWorkbook.Name
SheetName = ActiveSheet.Name
MyRanges(1) = "qdata1"
MyRanges(2) = "qdata2"
MyRanges(3) = "qdata3"
MyRanges(4) = "qdata4"
MyRanges(5) = "qdata5"
MyRanges(6) = "qdata6"
MyRanges(7) = "qdata7"
MyRanges(8) = "qdata8"
Workbooks.Open Filename:= _
"\\Impactsrv\shared\Templates\Quotes\Quote_Log.xls"
Workbooks("Quote_Log.xls").Activate
With Workbooks("Quote_Log.xls")
.Sheets("Quotes").Activate
With ActiveSheet
'find empty row
EmptyRow = 0
Do
EmptyRow = EmptyRow + 1
Loop Until IsEmpty(.Cells(EmptyRow, 1))
.Cells(EmptyRow, 1) = Date
'fill in other columns from named ranges
For a = 1 To UBound(MyRanges)
.Cells(EmptyRow, a + 1) = _
Workbooks(ThisWorkBook).Sheets(SheetName).Range(MyRanges(a))
Next a
End With
'save and close workbook
.Save
.Close
End With
'activate back to where you started
Workbooks(ThisWorkBook).Activate
End Sub
*****
How can I tell what is causing this malfunction? I take it a warning would
show if the Trust access to the Visual Basic Project setting was not checked.
the modules is not happening.
*****Module 3
Sub Quote_Wrapup()
'To stop screen flicker
Application.ScreenUpdating = False
ThisWorkBook.Activate
Sheet1.Range("quote_date") = Sheet1.Range("quote_date").Value
Sheet1.Range("qdata5,qdata6").Font.ColorIndex = 2
'To delete delivery address lines if 1st line empty
If IsEmpty(Range("deliver_line1")) _
Then Sheets(1).Range("deliver_rows").EntireRow.Delete
'No End If required as only one action as a result of the If
Sheet1.Range("Item_Nos").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheet1.Range("content") = Sheet1.Range("content").Value
Call NoDVinputMsg
Sheet1.Shapes("Group 31").Delete
Sheet1.Rows("1:1").Delete Shift:=xlUp
Sheet1.Shapes("Picture 14").Delete
Sheet1.Range("A:G").Interior.ColorIndex = xlNone
'Desperately trying to speed up delete column E!
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheet1.Range("base_p").Delete Shift:=xlToLeft
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Sheet1.Range("comm_disclines").Delete Shift:=xlUp
Sheet1.Range("boxes").Borders.LineStyle = x1None
Sheet1.Range("delterms_box").ClearContents
Sheet2.Name = "Terms&Conditions"
Sheet2.Range("instructions").Delete
Sheet2.Shapes("Picture 1").Delete
Sheet1.Range("qdata1").Select
Dim vbCom As Object
Call logquote
Application.ScreenUpdating = True
Sheet1.Range("A1:F1").HorizontalAlignment = xlCenter
Sheet1.Range("A1:F1").VerticalAlignment = xlCenter
Sheet1.Range("A1:F1").MergeCells = True
On Error Resume Next
Set vbCom = ActiveWorkbook.VBProject.VBComponents
vbCom.Remove VBComponent:= _
vbCom.Item("Module3")
vbCom.Remove VBComponent:= _
vbCom.Item("Module4")
On Error GoTo 0
End Sub
*****Module 4
ub NoDVinputMsg()
Dim rng As Range, cel As Range
Set rng = Nothing ' only if rng previously set
On Error Resume Next
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllValidation)
If Not rng Is Nothing Then
bDummy = rng.Validation.ShowInput
If Err.Number = 0 Then
' all same type, no need to loop
With rng.Validation
..InputTitle = ""
..InputMessage = ""
End With
Else
On Error GoTo 0
For Each cel In rng
With cel.Validation
..InputTitle = ""
..InputMessage = ""
End With
Next
End If
End If
End Sub
Sub logquote()
'
' logquote Macro
' Macro recorded 15/06/2007 by Sharon
'
'
Dim ThisWorkBook As String
Dim SheetName As String
Dim MyRanges(8) As String
Dim EmptyRow As Integer
Dim a As Integer 'to cyle through ranges
ThisWorkBook = ActiveWorkbook.Name
SheetName = ActiveSheet.Name
MyRanges(1) = "qdata1"
MyRanges(2) = "qdata2"
MyRanges(3) = "qdata3"
MyRanges(4) = "qdata4"
MyRanges(5) = "qdata5"
MyRanges(6) = "qdata6"
MyRanges(7) = "qdata7"
MyRanges(8) = "qdata8"
Workbooks.Open Filename:= _
"\\Impactsrv\shared\Templates\Quotes\Quote_Log.xls"
Workbooks("Quote_Log.xls").Activate
With Workbooks("Quote_Log.xls")
.Sheets("Quotes").Activate
With ActiveSheet
'find empty row
EmptyRow = 0
Do
EmptyRow = EmptyRow + 1
Loop Until IsEmpty(.Cells(EmptyRow, 1))
.Cells(EmptyRow, 1) = Date
'fill in other columns from named ranges
For a = 1 To UBound(MyRanges)
.Cells(EmptyRow, a + 1) = _
Workbooks(ThisWorkBook).Sheets(SheetName).Range(MyRanges(a))
Next a
End With
'save and close workbook
.Save
.Close
End With
'activate back to where you started
Workbooks(ThisWorkBook).Activate
End Sub
*****
How can I tell what is causing this malfunction? I take it a warning would
show if the Trust access to the Visual Basic Project setting was not checked.